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 base qw(Exporter);
  79
  80 BEGIN{
  81      $VERSION = 1.00;
  82      $DEBUG = 0 unless defined $DEBUG;
  83
  84      @EXPORT = ();
  85      %EXPORT_TAGS = (reopen    => [qw(reopen)],
  86                      submitter => [qw(set_submitter)],
  87                      severity => [qw(set_severity)],
  88                      affects => [qw(affects)],
  89                      summary => [qw(summary)],
  90                      owner   => [qw(owner)],
  91                      title   => [qw(set_title)],
  92                      forward => [qw(set_forwarded)],
  93                      found   => [qw(set_found set_fixed)],
  94                      fixed   => [qw(set_found set_fixed)],
  95                      package => [qw(set_package)],
  96                      block   => [qw(set_blocks)],
  97                      archive => [qw(bug_archive bug_unarchive),
  98                                 ],
  99                      log     => [qw(append_action_to_log),
 100                                 ],
 101                     );
 102      @EXPORT_OK = ();
 103      Exporter::export_ok_tags(keys %EXPORT_TAGS);
 104      $EXPORT_TAGS{all} = [@EXPORT_OK];
 105 }
 106
 107 use Debbugs::Config qw(:config);
 108 use Debbugs::Common qw(:lock buglog :misc get_hashname);
 109 use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages);
 110 use Debbugs::CGI qw(html_escape);
 111 use Debbugs::Log qw(:misc);
 112 use Debbugs::Recipients qw(:add);
 113 use Debbugs::Packages qw(:versions :mapping);
 114
 115 use Params::Validate qw(validate_with :types);
 116 use File::Path qw(mkpath);
 117 use IO::File;
 118
 119 use Debbugs::Text qw(:templates);
 120
 121 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
 122 use Debbugs::MIME qw(create_mime_message);
 123
 124 use Mail::RFC822::Address qw();
 125
 126 use POSIX qw(strftime);
 127
 128 use Storable qw(dclone nfreeze);
 129 use List::Util qw(first);
 130
 131 use Carp;
 132
 133 # These are a set of options which are common to all of these functions
 134
 135 my %common_options = (debug       => {type => SCALARREF|HANDLE,
 136                                       optional => 1,
 137                                      },
 138                       transcript  => {type => SCALARREF|HANDLE,
 139                                       optional => 1,
 140                                      },
 141                       affected_bugs => {type => HASHREF,
 142                                         optional => 1,
 143                                        },
 144                       affected_packages => {type => HASHREF,
 145                                             optional => 1,
 146                                            },
 147                       recipients    => {type => HASHREF,
 148                                         default => {},
 149                                        },
 150                       limit         => {type => HASHREF,
 151                                         default => {},
 152                                        },
 153                       show_bug_info => {type => BOOLEAN,
 154                                         default => 1,
 155                                        },
 156                       request_subject => {type => SCALAR,
 157                                           default => 'Unknown Subject',
 158                                          },
 159                       request_msgid    => {type => SCALAR,
 160                                            default => '',
 161                                           },
 162                       request_nn       => {type => SCALAR,
 163                                            optional => 1,
 164                                           },
 165                       request_replyto   => {type => SCALAR,
 166                                             optional => 1,
 167                                            },
 168                      );
 169
 170
 171 my %append_action_options =
 172      (action => {type => SCALAR,
 173                  optional => 1,
 174                 },
 175       requester => {type => SCALAR,
 176                     optional => 1,
 177                    },
 178       request_addr => {type => SCALAR,
 179                        optional => 1,
 180                       },
 181       location => {type => SCALAR,
 182                    optional => 1,
 183                   },
 184       message  => {type => SCALAR|ARRAYREF,
 185                    optional => 1,
 186                   },
 187       append_log => {type => BOOLEAN,
 188                      optional => 1,
 189                      depends => [qw(requester request_addr),
 190                                  qw(message),
 191                                 ],
 192                     },
 193      );
 194
 195
 196 # this is just a generic stub for Debbugs::Control functions.
 197 #
 198 # =head2 set_foo
 199 #
 200 #      eval {
 201 #           set_foo(bug          => $ref,
 202 #                   transcript   => $transcript,
 203 #                   ($dl > 0 ? (debug => $transcript):()),
 204 #                   requester    => $header{from},
 205 #                   request_addr => $controlrequestaddr,
 206 #                   message      => \@log,
 207 #                   affected_packages => \%affected_packages,
 208 #                   recipients   => \%recipients,
 209 #                   summary      => undef,
 210 #                  );
 211 #       };
 212 #       if ($@) {
 213 #           $errors++;
 214 #           print {$transcript} "Failed to set foo $ref bar: $@";
 215 #       }
 216 #
 217 # Foo frobinates
 218 #
 219 # =cut
 220 #
 221 # sub set_foo {
 222 #     my %param = validate_with(params => \@_,
 223 #                             spec   => {bug => {type   => SCALAR,
 224 #                                                regex  => qr/^\d+$/,
 225 #                                               },
 226 #                                        # specific options here
 227 #                                        %common_options,
 228 #                                        %append_action_options,
 229 #                                       },
 230 #                            );
 231 #     my %info =
 232 #       __begin_control(%param,
 233 #                       command  => 'foo'
 234 #                      );
 235 #     my ($debug,$transcript) =
 236 #       @info{qw(debug transcript)};
 237 #     my @data = @{$info{data}};
 238 #     my @bugs = @{$info{bugs}};
 239 #
 240 #     my $action = '';
 241 #     for my $data (@data) {
 242 #       append_action_to_log(bug => $data->{bug_num},
 243 #                            get_lock => 0,
 244 #                            __return_append_to_log_options(
 245 #                                                           %param,
 246 #                                                           action => $action,
 247 #                                                          ),
 248 #                           )
 249 #           if not exists $param{append_log} or $param{append_log};
 250 #       writebug($data->{bug_num},$data);
 251 #       print {$transcript} "$action\n";
 252 #     }
 253 #     __end_control(%info);
 254 # }
 255
 256
 257 =head2 set_blocks
 258
 259      eval {
 260             set_block(bug          => $ref,
 261                       transcript   => $transcript,
 262                       ($dl > 0 ? (debug => $transcript):()),
 263                       requester    => $header{from},
 264                       request_addr => $controlrequestaddr,
 265                       message      => \@log,
 266                       affected_packages => \%affected_packages,
 267                       recipients   => \%recipients,
 268                       block        => [],
 269                      );
 270         };
 271         if ($@) {
 272             $errors++;
 273             print {$transcript} "Failed to set blockers of $ref: $@";
 274         }
 275
 276 Alters the set of bugs that block this bug from being fixed
 277
 278 This requires altering both this bug (and those it's merged with) as
 279 well as the bugs that block this bug from being fixed (and those that
 280 it's merged with)
 281
 282 =over
 283
 284 =item block -- scalar or arrayref of blocking bugs to set, add or remove
 285
 286 =item add -- if true, add blocking bugs
 287
 288 =item remove -- if true, remove blocking bugs
 289
 290 =back
 291
 292 =cut
 293
 294 sub set_blocks {
 295     my %param = validate_with(params => \@_,
 296                               spec   => {bug => {type   => SCALAR,
 297                                                  regex  => qr/^\d+$/,
 298                                                 },
 299                                          # specific options here
 300                                          block => {type => SCALAR|ARRAYREF,
 301                                                    default => [],
 302                                                   },
 303                                          add    => {type => BOOLEAN,
 304                                                     default => 0,
 305                                                    },
 306                                          remove => {type => BOOLEAN,
 307                                                     default => 0,
 308                                                    },
 309                                          %common_options,
 310                                          %append_action_options,
 311                                         },
 312                              );
 313     if ($param{add} and $param{remove}) {
 314         croak "It's nonsensical to add and remove the same blocking bugs";
 315     }
 316     if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
 317         croak "Invalid blocking bug(s):".
 318             join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
 319     }
 320     my $mode = 'set';
 321     if (exists $param{add}) {
 322         $mode = 'add';
 323     }
 324     elsif (exists $param{remove}) {
 325         $mode = 'remove';
 326     }
 327
 328     my %info =
 329         __begin_control(%param,
 330                         command  => 'blocks'
 331                        );
 332     my ($debug,$transcript) =
 333         @info{qw(debug transcript)};
 334     my @data = @{$info{data}};
 335     my @bugs = @{$info{bugs}};
 336
 337
 338     # The first bit of this code is ugly, and should be cleaned up.
 339     # Its purpose is to populate %removed_blockers and %add_blockers
 340     # with all of the bugs that should be added or removed as blockers
 341     # of all of the bugs which are merged with $param{bug}
 342     my %ok_blockers;
 343     my %bad_blockers;
 344     for my $blocker (make_list($param{block})) {
 345         next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
 346         my $data = read_bug(bug=>$blocker,
 347                            );
 348         if (defined $data and not $data->{archive}) {
 349             $ok_blockers{$blocker} = 1;
 350             my @merged_bugs;
 351             push @merged_bugs, split(' ',$data->{mergedwith}) if length $data->{mergedwith};
 352             $ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
 353         }
 354         else {
 355             $bad_blockers{$blocker} = 1;
 356         }
 357     }
 358
 359     # throw an error if we are setting the blockers and there is a bad
 360     # blocker
 361     if (keys %bad_blockers and $mode eq 'set') {
 362         croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
 363             keys %ok_blockers?'':" and no known blocking bug(s)";
 364     }
 365     # if there are no ok blockers and we are not setting the blockers,
 366     # there's an error.
 367     if (not keys %ok_blockers and $mode ne 'set') {
 368         print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
 369         if (keys %bad_blockers) {
 370             croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
 371         }
 372         __end_control(%info);
 373         return;
 374     }
 375
 376     my @change_blockers = keys %ok_blockers;
 377
 378     my %removed_blockers;
 379     my %added_blockers;
 380     my $action = '';
 381     my @blockers = map {split ' ', $_->{blockedby}} @data;
 382     my %blockers;
 383     @blockers{@blockers} = (1) x @blockers;
 384
 385     # it is nonsensical for a bug to block itself (or a merged
 386     # partner); We currently don't allow removal because we'd possibly
 387     # deadlock
 388
 389     my %bugs;
 390     @bugs{@bugs} = (1) x @bugs;
 391     for my $blocker (@change_blockers) {
 392         if ($bugs{$blocker}) {
 393             croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
 394         }
 395     }
 396     @blockers = keys %blockers;
 397     if ($param{add}) {
 398         %removed_blockers = ();
 399         for my $blocker (@change_blockers) {
 400             next if exists $blockers{$blocker};
 401             $blockers{$blocker} = 1;
 402             $added_blockers{$blocker} = 1;
 403         }
 404     }
 405     elsif ($param{remove}) {
 406         %added_blockers = ();
 407         for my $blocker (@change_blockers) {
 408             next if exists $removed_blockers{$blocker};
 409             delete $blockers{$blocker};
 410             $removed_blockers{$blocker} = 1;
 411         }
 412     }
 413     else {
 414         @removed_blockers{@blockers} = (1) x @blockers;
 415         %blockers = ();
 416         for my $blocker (@change_blockers) {
 417             next if exists $blockers{$blocker};
 418             $blockers{$blocker} = 1;
 419             if (exists $removed_blockers{$blocker}) {
 420                 delete $removed_blockers{$blocker};
 421             }
 422             else {
 423                 $added_blockers{$blocker} = 1;
 424             }
 425         }
 426     }
 427     my @new_blockers = keys %blockers;
 428     for my $data (@data) {
 429         my $old_data = dclone($data);
 430         # remove blockers and/or add new ones as appropriate
 431         if ($data->{blockedby} eq '') {
 432             print {$transcript} "Was not blocked by any bugs.\n";
 433         } else {
 434             print {$transcript} "Was blocked by: $data->{blockedby}\n";
 435         }
 436         my @changed;
 437         push @changed, 'added blocking bug(s) '.english_join([keys %added_blockers]) if keys %added_blockers;
 438         push @changed, 'removed blocking bug(s) '.english_join([keys %removed_blockers]) if keys %removed_blockers;
 439         $action = ucfirst(join ('; ',@changed)) if @changed;
 440         if (not @changed) {
 441             print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
 442                 unless __internal_request();
 443             next;
 444         }
 445         $data->{blockedby} = join(' ',keys %blockers);
 446         append_action_to_log(bug => $data->{bug_num},
 447                              command  => 'block',
 448                              old_data => $old_data,
 449                              new_data => $data,
 450                              get_lock => 0,
 451                              __return_append_to_log_options(
 452                                                             %param,
 453                                                             action => $action,
 454                                                            ),
 455                             )
 456             if not exists $param{append_log} or $param{append_log};
 457         writebug($data->{bug_num},$data);
 458         print {$transcript} "$action\n";
 459     }
 460     # we do this bit below to avoid code duplication
 461     my %mungable_blocks;
 462     $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
 463     $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
 464     for my $add_remove (keys %mungable_blocks) {
 465         my @munge_blockers;
 466         my %munge_blockers;
 467         my $block_locks = 0;
 468         for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
 469             next if $munge_blockers{$blocker};
 470             my ($new_locks, @blocking_data) =
 471                 lock_read_all_merged_bugs($blocker,
 472                                           ($param{archived}?'archive':()));
 473             if (not @blocking_data) {
 474                 unfilelock() for $new_locks;
 475                 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
 476             }
 477             for (map {$_->{bug_num}} @blocking_data) {
 478                 $munge_blockers{$_} = 1;
 479             }
 480             for my $data (@blocking_data) {
 481                 my $old_data = dclone($data);
 482                 my %blocks;
 483                 %blocks = split ' ', $data->{blocks};
 484                 my @blocks;
 485                 for my $bug (@bugs) {
 486                     if ($add_remove eq 'remove') {
 487                         next unless exists $blocks{$bug};
 488                         delete $blocks{$bug};
 489                     }
 490                     else {
 491                         next if exists $blocks{$bug};
 492                         $blocks{$bug} = 1;
 493                     }
 494                     push @blocks, $bug;
 495                 }
 496                 $data->{blocks} = join(' ',sort keys %blocks);
 497                 my $action = ($add_remove eq 'add'?'Added':'Removed').
 498                     " indication that bug $data->{bug_num} blocks".
 499                     join(',',@blocks);
 500                 append_action_to_log(bug => $data->{bug_num},
 501                                      command => 'block',
 502                                      old_data => $old_data,
 503                                      new_data => $data,
 504                                      get_lock => 0,
 505                                      __return_append_to_log_options(%param,
 506                                                                    action => $action
 507                                                                    )
 508                                     );
 509             }
 510             __handle_affected_packages(%param,data=>\@blocking_data);
 511             add_recipients(recipients => $param{recipients},
 512                            actions_taken => {blocks => 1},
 513                            data       => \@blocking_data,
 514                            debug      => $debug,
 515                            transcript => $transcript,
 516                           );
 517
 518             unfilelock() for $new_locks;
 519         }
 520     }
 521     __end_control(%info);
 522 }
 523
 524
 525
 526 =head2 set_tag
 527
 528      eval {
 529             set_tag(bug          => $ref,
 530                     transcript   => $transcript,
 531                     ($dl > 0 ? (debug => $transcript):()),
 532                     requester    => $header{from},
 533                     request_addr => $controlrequestaddr,
 534                     message      => \@log,
 535                     affected_packages => \%affected_packages,
 536                     recipients   => \%recipients,
 537                     tag          => [],
 538                     add          => 1,
 539                    );
 540         };
 541         if ($@) {
 542             $errors++;
 543             print {$transcript} "Failed to set tag on $ref: $@";
 544         }
 545
 546
 547 Sets, adds, or removes the specified tags on a bug
 548
 549 =over
 550
 551 =item tag -- scalar or arrayref of tags to set, add or remove
 552
 553 =item add -- if true, add tags
 554
 555 =item remove -- if true, remove tags
 556
 557 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
 558 passed.
 559
 560 =back
 561
 562 =cut
 563
 564 sub set_tag {
 565     my %param = validate_with(params => \@_,
 566                               spec   => {bug => {type   => SCALAR,
 567                                                  regex  => qr/^\d+$/,
 568                                                 },
 569                                          # specific options here
 570                                          tag    => {type => SCALAR|ARRAYREF,
 571                                                     default => [],
 572                                                    },
 573                                          add      => {type => BOOLEAN,
 574                                                       default => 0,
 575                                                      },
 576                                          remove   => {type => BOOLEAN,
 577                                                       default => 0,
 578                                                      },
 579                                          warn_on_bad_tags => {type => BOOLEAN,
 580                                                               default => 1,
 581                                                              },
 582                                          %common_options,
 583                                          %append_action_options,
 584                                         },
 585                              );
 586     if ($param{add} and $param{remove}) {
 587         croak "It's nonsensical to add and remove the same tags";
 588     }
 589
 590     my %info =
 591         __begin_control(%param,
 592                         command  => 'tag'
 593                        );
 594     my ($debug,$transcript) =
 595         @info{qw(debug transcript)};
 596     my @data = @{$info{data}};
 597     my @bugs = @{$info{bugs}};
 598     my @tags = make_list($param{tag});
 599     if (not @tags and ($param{remove} or $param{add})) {
 600         if ($param{remove}) {
 601             print {$transcript} "Requested to remove no tags; doing nothing.\n";
 602         }
 603         else {
 604             print {$transcript} "Requested to add no tags; doing nothing.\n";
 605         }
 606         __end_control(%info);
 607         return;
 608     }
 609     # first things first, make the versions fully qualified source
 610     # versions
 611     for my $data (@data) {
 612         my $action = 'Did not alter tags';
 613         my %tag_added = ();
 614         my %tag_removed = ();
 615         my %fixed_removed = ();
 616         my @old_tags = split /\,\s*/, $data->{tags};
 617         my %tags;
 618         @tags{@old_tags} = (1) x @old_tags;
 619         my $reopened = 0;
 620         my $old_data = dclone($data);
 621         if (not $param{add} and not $param{remove}) {
 622             $tag_removed{$_} = 1 for @old_tags;
 623             %tags = ();
 624         }
 625         my @bad_tags = ();
 626         for my $tag (@tags) {
 627             if (not $param{remove} and
 628                 not defined first {$_ eq $tag} @{$config{tags}}) {
 629                 push @bad_tags, $tag;
 630                 next;
 631             }
 632             if ($param{add}) {
 633                 if (not exists $tags{$tag}) {
 634                     $tags{$tag} = 1;
 635                     $tag_added{$tag} = 1;
 636                 }
 637             }
 638             elsif ($param{remove}) {
 639                 if (exists $tags{$tag}) {
 640                     delete $tags{$tag};
 641                     $tag_removed{$tag} = 1;
 642                 }
 643             }
 644             else {
 645                 if (exists $tag_removed{$tag}) {
 646                     delete $tag_removed{$tag};
 647                 }
 648                 else {
 649                     $tag_added{$tag} = 1;
 650                 }
 651                 $tags{$tag} = 1;
 652             }
 653         }
 654         if (@bad_tags and $param{warn_on_bad_tags}) {
 655             print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
 656             print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
 657         }
 658         $data->{tags} = join(', ',keys %tags); # double check this
 659
 660         my @changed;
 661         push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
 662         push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
 663         $action = ucfirst(join ('; ',@changed)) if @changed;
 664         if (not @changed) {
 665             print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
 666                 unless __internal_request();
 667             next;
 668         }
 669         $action .= '.';
 670         append_action_to_log(bug => $data->{bug_num},
 671                              get_lock => 0,
 672                              command  => 'tag',
 673                              old_data => $old_data,
 674                              new_data => $data,
 675                              __return_append_to_log_options(
 676                                                             %param,
 677                                                             action => $action,
 678                                                            ),
 679                             )
 680             if not exists $param{append_log} or $param{append_log};
 681         writebug($data->{bug_num},$data);
 682         print {$transcript} "$action\n";
 683     }
 684     __end_control(%info);
 685 }
 686
 687
 688
 689 =head2 set_severity
 690
 691      eval {
 692             set_severity(bug          => $ref,
 693                          transcript   => $transcript,
 694                          ($dl > 0 ? (debug => $transcript):()),
 695                          requester    => $header{from},
 696                          request_addr => $controlrequestaddr,
 697                          message      => \@log,
 698                          affected_packages => \%affected_packages,
 699                          recipients   => \%recipients,
 700                          severity     => 'normal',
 701                         );
 702         };
 703         if ($@) {
 704             $errors++;
 705             print {$transcript} "Failed to set the severity of bug $ref: $@";
 706         }
 707
 708 Sets the severity of a bug. If severity is not passed, is undefined,
 709 or has zero length, sets the severity to the defafult severity.
 710
 711 =cut
 712
 713 sub set_severity {
 714     my %param = validate_with(params => \@_,
 715                               spec   => {bug => {type   => SCALAR,
 716                                                  regex  => qr/^\d+$/,
 717                                                 },
 718                                          # specific options here
 719                                          severity => {type => SCALAR|UNDEF,
 720                                                       default => $config{default_severity},
 721                                                      },
 722                                          %common_options,
 723                                          %append_action_options,
 724                                         },
 725                              );
 726     if (not defined $param{severity} or
 727         not length $param{severity}
 728        ) {
 729         $param{severity} = $config{default_severity};
 730     }
 731
 732     # check validity of new severity
 733     if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
 734         die "Severity '$param{severity}' is not a valid severity level";
 735     }
 736     my %info =
 737         __begin_control(%param,
 738                         command  => 'severity'
 739                        );
 740     my ($debug,$transcript) =
 741         @info{qw(debug transcript)};
 742     my @data = @{$info{data}};
 743     my @bugs = @{$info{bugs}};
 744
 745     my $action = '';
 746     for my $data (@data) {
 747         if (not defined $data->{severity}) {
 748             $data->{severity} = $param{severity};
 749             $action = "Severity set to '$param{severity}'\n";
 750         }
 751         else {
 752             if ($data->{severity} eq '') {
 753                 $data->{severity} = $config{default_severity};
 754             }
 755             if ($data->{severity} eq $param{severity}) {
 756                 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
 757                 next;
 758             }
 759             $action = "Severity set to '$param{severity}' from '$data->{severity}'\n";
 760             $data->{severity} = $param{severity};
 761         }
 762         append_action_to_log(bug => $data->{bug_num},
 763                              get_lock => 0,
 764                              __return_append_to_log_options(
 765                                                             %param,
 766                                                             action => $action,
 767                                                            ),
 768                             )
 769             if not exists $param{append_log} or $param{append_log};
 770         writebug($data->{bug_num},$data);
 771         print {$transcript} "$action\n";
 772     }
 773     __end_control(%info);
 774 }
 775
 776
 777 =head2 reopen
 778
 779      eval {
 780             set_foo(bug          => $ref,
 781                     transcript   => $transcript,
 782                     ($dl > 0 ? (debug => $transcript):()),
 783                     requester    => $header{from},
 784                     request_addr => $controlrequestaddr,
 785                     message      => \@log,
 786                   affected_packages => \%affected_packages,
 787                     recipients   => \%recipients,
 788                     summary      => undef,
 789                  );
 790         };
 791         if ($@) {
 792             $errors++;
 793             print {$transcript} "Failed to set foo $ref bar: $@";
 794         }
 795
 796 Foo frobinates
 797
 798 =cut
 799
 800 sub reopen {
 801     my %param = validate_with(params => \@_,
 802                               spec   => {bug => {type   => SCALAR,
 803                                                  regex  => qr/^\d+$/,
 804                                                 },
 805                                          # specific options here
 806                                          submitter => {type => SCALAR|UNDEF,
 807                                                        default => undef,
 808                                                       },
 809                                          %common_options,
 810                                          %append_action_options,
 811                                         },
 812                              );
 813
 814     $param{submitter} = undef if defined $param{submitter} and
 815         not length $param{submitter};
 816
 817     if (defined $param{submitter} and
 818         not Mail::RFC822::Address::valid($param{submitter})) {
 819         die "New submitter address $param{submitter} is not a valid e-mail address";
 820     }
 821
 822     my %info =
 823         __begin_control(%param,
 824                         command  => 'reopen'
 825                        );
 826     my ($debug,$transcript) =
 827         @info{qw(debug transcript)};
 828     my @data = @{$info{data}};
 829     my @bugs = @{$info{bugs}};
 830     my $action ='';
 831
 832     my $warn_fixed = 1; # avoid warning multiple times if there are
 833                         # fixed versions
 834     my @change_submitter = ();
 835     my @bugs_to_reopen = ();
 836     for my $data (@data) {
 837         if (not exists $data->{done} or
 838             not defined $data->{done} or
 839             not length $data->{done}) {
 840             print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
 841             __end_control(%info);
 842             return;
 843         }
 844         if (@{$data->{fixed_versions}} and $warn_fixed) {
 845             print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
 846             print {$transcript} "you may need to use 'found' to remove fixed versions.\n";
 847             $warn_fixed = 0;
 848         }
 849         if (defined $param{submitter} and length $param{submitter}
 850             and $data->{originator} ne $param{submitter}) {
 851             push @change_submitter,$data->{bug_num};
 852         }
 853     }
 854     __end_control(%info);
 855     my @params_for_subcalls =
 856         map {exists $param{$_}?($_,$param{$_}):()}
 857             (keys %common_options,
 858              keys %append_action_options,
 859             );
 860
 861     for my $bug (@change_submitter) {
 862         set_submitter(bug=>$bug,
 863                       submitter => $param{submitter},
 864                       @params_for_subcalls,
 865                      );
 866     }
 867     set_fixed(fixed => [],
 868               bug => $param{bug},
 869               reopen => 1,
 870              );
 871 }
 872
 873
 874 =head2 set_submitter
 875
 876      eval {
 877             set_submitter(bug          => $ref,
 878                           transcript   => $transcript,
 879                           ($dl > 0 ? (debug => $transcript):()),
 880                           requester    => $header{from},
 881                           request_addr => $controlrequestaddr,
 882                           message      => \@log,
 883                           affected_packages => \%affected_packages,
 884                           recipients   => \%recipients,
 885                           submitter    => $new_submitter,
 886                           notify_submitter => 1,
 887                           );
 888         };
 889         if ($@) {
 890             $errors++;
 891             print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
 892         }
 893
 894 Sets the submitter of a bug. If notify_submitter is true (the
 895 default), notifies the old submitter of a bug on changes
 896
 897 =cut
 898
 899 sub set_submitter {
 900     my %param = validate_with(params => \@_,
 901                               spec   => {bug => {type   => SCALAR,
 902                                                  regex  => qr/^\d+$/,
 903                                                 },
 904                                          # specific options here
 905                                          submitter => {type => SCALAR,
 906                                                       },
 907                                          notify_submitter => {type => BOOLEAN,
 908                                                               default => 1,
 909                                                              },
 910                                          %common_options,
 911                                          %append_action_options,
 912                                         },
 913                              );
 914     if (not Mail::RFC822::Address::valid($param{submitter})) {
 915         die "New submitter address $param{submitter} is not a valid e-mail address";
 916     }
 917     my %info =
 918         __begin_control(%param,
 919                         command  => 'submitter'
 920                        );
 921     my ($debug,$transcript) =
 922         @info{qw(debug transcript)};
 923     my @data = @{$info{data}};
 924     my @bugs = @{$info{bugs}};
 925     my $action = '';
 926     # here we only concern ourselves with the first of the merged bugs
 927     for my $data ($data[0]) {
 928         my $notify_old_submitter = 0;
 929         my $old_data = dclone($data);
 930         print {$debug} "Going to change bug submitter\n";
 931         if (((not defined $param{submitter} or not length $param{submitter}) and
 932               (not defined $data->{originator} or not length $data->{originator})) or
 933              (defined $param{submitter} and defined $data->{originator} and
 934               $param{submitter} eq $data->{originator})) {
 935             print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
 936                 unless __internal_request();
 937             next;
 938         }
 939         else {
 940             if (defined $data->{originator} and length($data->{originator})) {
 941                 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
 942                 $notify_old_submitter = 1;
 943             }
 944             else {
 945                 $action= "Set $config{bug} submitter to '$param{submitter}'.";
 946             }
 947             $data->{originator} = $param{submitter};
 948         }
 949         append_action_to_log(bug => $data->{bug_num},
 950                              command => 'submitter',
 951                              new_data => $data,
 952                              old_data => $old_data,
 953                              get_lock => 0,
 954                              __return_append_to_log_options(
 955                                                             %param,
 956                                                             action => $action,
 957                                                            ),
 958                             )
 959             if not exists $param{append_log} or $param{append_log};
 960         writebug($data->{bug_num},$data);
 961         print {$transcript} "$action\n";
 962         # notify old submitter
 963         if ($notify_old_submitter and $param{notify_submitter}) {
 964             send_mail_message(message =>
 965                               create_mime_message([default_headers(queue_file => $param{request_nn},
 966                                                                    data => $data,
 967                                                                    msgid => $param{request_msgid},
 968                                                                    msgtype => 'ack',
 969                                                                    pr_msg  => 'submitter-changed',
 970                                                                    headers =>
 971                                                                    [To => $old_data->{submitter},
 972                                                                     Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
 973                                                                    ],
 974                                                                   )
 975                                                   ],
 976                                                   __message_body_template('mail/submitter_changed',
 977                                                                           {old_data => $old_data,
 978                                                                            data     => $data,
 979                                                                            replyto  => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
 980                                                                            config   => \%config,
 981                                                                           })
 982                                                  ),
 983                               recipients => $old_data->{submitter},
 984                              );
 985         }
 986     }
 987     __end_control(%info);
 988 }
 989
 990
 991
 992 =head2 set_forwarded
 993
 994      eval {
 995             set_forwarded(bug          => $ref,
 996                           transcript   => $transcript,
 997                           ($dl > 0 ? (debug => $transcript):()),
 998                           requester    => $header{from},
 999                           request_addr => $controlrequestaddr,
1000                           message      => \@log,
1001                           affected_packages => \%affected_packages,
1002                           recipients   => \%recipients,
1003                           forwarded    => $forward_to,
1004                           );
1005         };
1006         if ($@) {
1007             $errors++;
1008             print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1009         }
1010
1011 Sets the location to which a bug is forwarded. Given an undef
1012 forwarded, unsets forwarded.
1013
1014
1015 =cut
1016
1017 sub set_forwarded {
1018     my %param = validate_with(params => \@_,
1019                               spec   => {bug => {type   => SCALAR,
1020                                                  regex  => qr/^\d+$/,
1021                                                 },
1022                                          # specific options here
1023                                          forwarded => {type => SCALAR|UNDEF,
1024                                                       },
1025                                          %common_options,
1026                                          %append_action_options,
1027                                         },
1028                              );
1029     if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1030         die "Non-printable characters are not allowed in the forwarded field";
1031     }
1032     my %info =
1033         __begin_control(%param,
1034                         command  => 'forwarded'
1035                        );
1036     my ($debug,$transcript) =
1037         @info{qw(debug transcript)};
1038     my @data = @{$info{data}};
1039     my @bugs = @{$info{bugs}};
1040     my $action = '';
1041     for my $data (@data) {
1042         my $old_data = dclone($data);
1043         print {$debug} "Going to change bug forwarded\n";
1044         if (((not defined $param{forwarded} or not length $param{forwarded}) and
1045               (not defined $data->{forwarded} or not length $data->{forwarded})) or
1046              $param{forwarded} eq $data->{forwarded}) {
1047             print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1048                 unless __internal_request();
1049             next;
1050         }
1051         else {
1052             if (not defined $param{forwarded}) {
1053                 $action= "Unset $config{bug} forwarded-to-address";
1054             }
1055             elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1056                 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1057             }
1058             else {
1059                 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1060             }
1061             $data->{forwarded} = $param{forwarded};
1062         }
1063         append_action_to_log(bug => $data->{bug_num},
1064                              command => 'forwarded',
1065                              new_data => $data,
1066                              old_data => $old_data,
1067                              get_lock => 0,
1068                              __return_append_to_log_options(
1069                                                             %param,
1070                                                             action => $action,
1071                                                            ),
1072                             )
1073             if not exists $param{append_log} or $param{append_log};
1074         writebug($data->{bug_num},$data);
1075         print {$transcript} "$action\n";
1076     }
1077     __end_control(%info);
1078 }
1079
1080
1081
1082
1083 =head2 set_title
1084
1085      eval {
1086             set_title(bug          => $ref,
1087                       transcript   => $transcript,
1088                       ($dl > 0 ? (debug => $transcript):()),
1089                       requester    => $header{from},
1090                       request_addr => $controlrequestaddr,
1091                       message      => \@log,
1092                       affected_packages => \%affected_packages,
1093                       recipients   => \%recipients,
1094                       title        => $new_title,
1095                       );
1096         };
1097         if ($@) {
1098             $errors++;
1099             print {$transcript} "Failed to set the title of $ref: $@";
1100         }
1101
1102 Sets the title of a specific bug
1103
1104
1105 =cut
1106
1107 sub set_title {
1108     my %param = validate_with(params => \@_,
1109                               spec   => {bug => {type   => SCALAR,
1110                                                  regex  => qr/^\d+$/,
1111                                                 },
1112                                          # specific options here
1113                                          title => {type => SCALAR,
1114                                                   },
1115                                          %common_options,
1116                                          %append_action_options,
1117                                         },
1118                              );
1119     if ($param{title} =~ /[^[:print:]]/) {
1120         die "Non-printable characters are not allowed in bug titles";
1121     }
1122
1123     my %info = __begin_control(%param,
1124                                command  => 'title',
1125                               );
1126     my ($debug,$transcript) =
1127         @info{qw(debug transcript)};
1128     my @data = @{$info{data}};
1129     my @bugs = @{$info{bugs}};
1130     my $action = '';
1131     for my $data (@data) {
1132         my $old_data = dclone($data);
1133         print {$debug} "Going to change bug title\n";
1134         if (defined $data->{subject} and length($data->{subject}) and
1135             $data->{subject} eq $param{title}) {
1136             print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1137                 unless __internal_request();
1138             next;
1139         }
1140         else {
1141             if (defined $data->{subject} and length($data->{subject})) {
1142                 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1143             } else {
1144                 $action= "Set $config{bug} title to '$param{title}'.";
1145             }
1146             $data->{subject} = $param{title};
1147         }
1148         append_action_to_log(bug => $data->{bug_num},
1149                              command => 'title',
1150                              new_data => $data,
1151                              old_data => $old_data,
1152                              get_lock => 0,
1153                              __return_append_to_log_options(
1154                                                             %param,
1155                                                             action => $action,
1156                                                            ),
1157                             )
1158             if not exists $param{append_log} or $param{append_log};
1159         writebug($data->{bug_num},$data);
1160         print {$transcript} "$action\n";
1161     }
1162     __end_control(%info);
1163 }
1164
1165
1166 =head2 set_package
1167
1168      eval {
1169             set_package(bug          => $ref,
1170                         transcript   => $transcript,
1171                         ($dl > 0 ? (debug => $transcript):()),
1172                         requester    => $header{from},
1173                         request_addr => $controlrequestaddr,
1174                         message      => \@log,
1175                         affected_packages => \%affected_packages,
1176                         recipients   => \%recipients,
1177                         package      => $new_package,
1178                         is_source    => 0,
1179                        );
1180         };
1181         if ($@) {
1182             $errors++;
1183             print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1184         }
1185
1186 Indicates that a bug is in a particular package. If is_source is true,
1187 indicates that the package is a source package. [Internally, this
1188 causes src: to be prepended to the package name.]
1189
1190 The default for is_source is 0. As a special case, if the package
1191 starts with 'src:', it is assumed to be a source package and is_source
1192 is overridden.
1193
1194 The package option must match the package_name_re regex.
1195
1196 =cut
1197
1198 sub set_package {
1199     my %param = validate_with(params => \@_,
1200                               spec   => {bug => {type   => SCALAR,
1201                                                  regex  => qr/^\d+$/,
1202                                                 },
1203                                          # specific options here
1204                                          package => {type => SCALAR|ARRAYREF,
1205                                                     },
1206                                          is_source => {type => BOOLEAN,
1207                                                        default => 0,
1208                                                       },
1209                                          %common_options,
1210                                          %append_action_options,
1211                                         },
1212                              );
1213     my @new_packages = map {splitpackages($_)} make_list($param{package});
1214     if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1215         croak "Invalid package name '".
1216             join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1217                 "'";
1218     }
1219     my %info = __begin_control(%param,
1220                                command  => 'package',
1221                               );
1222     my ($debug,$transcript) =
1223         @info{qw(debug transcript)};
1224     my @data = @{$info{data}};
1225     my @bugs = @{$info{bugs}};
1226     # clean up the new package
1227     my $new_package =
1228         join(',',
1229              map {my $temp = $_;
1230                   ($temp =~ s/^src:// or
1231                    $param{is_source}) ? 'src:'.$temp:$temp;
1232               } @new_packages);
1233
1234     my $action = '';
1235     my $package_reassigned = 0;
1236     for my $data (@data) {
1237         my $old_data = dclone($data);
1238         print {$debug} "Going to change assigned package\n";
1239         if (defined $data->{package} and length($data->{package}) and
1240             $data->{package} eq $new_package) {
1241             print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1242                 unless __internal_request();
1243             next;
1244         }
1245         else {
1246             if (defined $data->{package} and length($data->{package})) {
1247                 $package_reassigned = 1;
1248                 $action= "$config{bug} reassigned from package '$data->{package}'".
1249                     " to '$new_package'.";
1250             } else {
1251                 $action= "$config{bug} assigned to package '$new_package'.";
1252             }
1253             $data->{package} = $new_package;
1254         }
1255         append_action_to_log(bug => $data->{bug_num},
1256                              command => 'package',
1257                              new_data => $data,
1258                              old_data => $old_data,
1259                              get_lock => 0,
1260                              __return_append_to_log_options(
1261                                                             %param,
1262                                                             action => $action,
1263                                                            ),
1264                             )
1265             if not exists $param{append_log} or $param{append_log};
1266         writebug($data->{bug_num},$data);
1267         print {$transcript} "$action\n";
1268     }
1269     __end_control(%info);
1270     # Only clear the fixed/found versions if the package has been
1271     # reassigned
1272     if ($package_reassigned) {
1273         my @params_for_found_fixed =
1274             map {exists $param{$_}?($_,$param{$_}):()}
1275                 ('bug',
1276                  keys %common_options,
1277                  keys %append_action_options,
1278                 );
1279         set_found(found => [],
1280                   @params_for_found_fixed,
1281                  );
1282         set_fixed(fixed => [],
1283                   @params_for_found_fixed,
1284                  );
1285     }
1286 }
1287
1288 =head2 set_found
1289
1290      eval {
1291             set_found(bug          => $ref,
1292                       transcript   => $transcript,
1293                       ($dl > 0 ? (debug => $transcript):()),
1294                       requester    => $header{from},
1295                       request_addr => $controlrequestaddr,
1296                       message      => \@log,
1297                       affected_packages => \%affected_packages,
1298                       recipients   => \%recipients,
1299                       found        => [],
1300                       add          => 1,
1301                      );
1302         };
1303         if ($@) {
1304             $errors++;
1305             print {$transcript} "Failed to set found on $ref: $@";
1306         }
1307
1308
1309 Sets, adds, or removes the specified found versions of a package
1310
1311 If the version list is empty, and the bug is currently not "done",
1312 causes the done field to be cleared.
1313
1314 If any of the versions added to found are greater than any version in
1315 which the bug is fixed (or when the bug is found and there are no
1316 fixed versions) the done field is cleared.
1317
1318 =cut
1319
1320 sub set_found {
1321     my %param = validate_with(params => \@_,
1322                               spec   => {bug => {type   => SCALAR,
1323                                                  regex  => qr/^\d+$/,
1324                                                 },
1325                                          # specific options here
1326                                          found    => {type => SCALAR|ARRAYREF,
1327                                                       default => [],
1328                                                      },
1329                                          add      => {type => BOOLEAN,
1330                                                       default => 0,
1331                                                      },
1332                                          remove   => {type => BOOLEAN,
1333                                                       default => 0,
1334                                                      },
1335                                          %common_options,
1336                                          %append_action_options,
1337                                         },
1338                              );
1339     if ($param{add} and $param{remove}) {
1340         croak "It's nonsensical to add and remove the same versions";
1341     }
1342
1343     my %info =
1344         __begin_control(%param,
1345                         command  => 'found'
1346                        );
1347     my ($debug,$transcript) =
1348         @info{qw(debug transcript)};
1349     my @data = @{$info{data}};
1350     my @bugs = @{$info{bugs}};
1351     my %versions;
1352     for my $version (make_list($param{found})) {
1353         next unless defined $version;
1354         $versions{$version} =
1355             [make_source_versions(package => [splitpackages($data[0]{package})],
1356                                   warnings => $transcript,
1357                                   debug    => $debug,
1358                                   guess_source => 0,
1359                                   versions     => $version,
1360                                  )
1361             ];
1362         # This is really ugly, but it's what we have to do
1363         if (not @{$versions{$version}}) {
1364             print {$transcript} "Unable to make a source version for version '$version'\n";
1365         }
1366     }
1367     if (not keys %versions and ($param{remove} or $param{add})) {
1368         if ($param{remove}) {
1369             print {$transcript} "Requested to remove no versions; doing nothing.\n";
1370         }
1371         else {
1372             print {$transcript} "Requested to add no versions; doing nothing.\n";
1373         }
1374         __end_control(%info);
1375         return;
1376     }
1377     # first things first, make the versions fully qualified source
1378     # versions
1379     for my $data (@data) {
1380         # The 'done' field gets a bit weird with version tracking,
1381         # because a bug may be closed by multiple people in different
1382         # branches. Until we have something more flexible, we set it
1383         # every time a bug is fixed, and clear it when a bug is found
1384         # in a version greater than any version in which the bug is
1385         # fixed or when a bug is found and there is no fixed version
1386         my $action = 'Did not alter found versions';
1387         my %found_added = ();
1388         my %found_removed = ();
1389         my %fixed_removed = ();
1390         my $reopened = 0;
1391         my $old_data = dclone($data);
1392         if (not $param{add} and not $param{remove}) {
1393             $found_removed{$_} = 1 for @{$data->{found_versions}};
1394             $data->{found_versions} = [];
1395         }
1396         my %found_versions;
1397         @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1398         my %fixed_versions;
1399         @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1400         for my $version (keys %versions) {
1401             if ($param{add}) {
1402                 my @svers = @{$versions{$version}};
1403                 if (not @svers) {
1404                     @svers = $version;
1405                 }
1406                 for my $sver (@svers) {
1407                     if (not exists $found_versions{$sver}) {
1408                         $found_versions{$sver} = 1;
1409                         $found_added{$sver} = 1;
1410                     }
1411                     # if the found we are adding matches any fixed
1412                     # versions, remove them
1413                     my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1414                     delete $fixed_versions{$_} for @temp;
1415                     $fixed_removed{$_} = 1 for @temp;
1416                 }
1417
1418                 # We only care about reopening the bug if the bug is
1419                 # not done
1420                 if (defined $data->{done} and length $data->{done}) {
1421                     my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1422                         map {m{([^/]+)$}; $1;} @svers;
1423                     # determine if we need to reopen
1424                     my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1425                         map {m{([^/]+)$}; $1;} keys %fixed_versions;
1426                     if (not @fixed_order or
1427                         (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1428                         $reopened = 1;
1429                         $data->{done} = '';
1430                     }
1431                 }
1432             }
1433             elsif ($param{remove}) {
1434                 # in the case of removal, we only concern ourself with
1435                 # the version passed, not the source version it maps
1436                 # to
1437                 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1438                 delete $found_versions{$_} for @temp;
1439                 $found_removed{$_} = 1 for @temp;
1440             }
1441             else {
1442                 # set the keys to exactly these values
1443                 my @svers = @{$versions{$version}};
1444                 if (not @svers) {
1445                     @svers = $version;
1446                 }
1447                 for my $sver (@svers) {
1448                     if (not exists $found_versions{$sver}) {
1449                         $found_versions{$sver} = 1;
1450                         if (exists $found_removed{$sver}) {
1451                             delete $found_removed{$sver};
1452                         }
1453                         else {
1454                             $found_added{$sver} = 1;
1455                         }
1456                     }
1457                 }
1458             }
1459         }
1460
1461         $data->{found_versions} = [keys %found_versions];
1462         $data->{fixed_versions} = [keys %fixed_versions];
1463
1464         my @changed;
1465         push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1466         push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1467 #       push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1468         push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1469         $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1470         if ($reopened) {
1471             $action .= " and reopened"
1472         }
1473         if (not $reopened and not @changed) {
1474             print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1475                 unless __internal_request();
1476             next;
1477         }
1478         $action .= '.';
1479         append_action_to_log(bug => $data->{bug_num},
1480                              get_lock => 0,
1481                              command  => 'found',
1482                              old_data => $old_data,
1483                              new_data => $data,
1484                              __return_append_to_log_options(
1485                                                             %param,
1486                                                             action => $action,
1487                                                            ),
1488                             )
1489             if not exists $param{append_log} or $param{append_log};
1490         writebug($data->{bug_num},$data);
1491         print {$transcript} "$action\n";
1492     }
1493     __end_control(%info);
1494 }
1495
1496 =head2 set_fixed
1497
1498      eval {
1499             set_fixed(bug          => $ref,
1500                       transcript   => $transcript,
1501                       ($dl > 0 ? (debug => $transcript):()),
1502                       requester    => $header{from},
1503                       request_addr => $controlrequestaddr,
1504                       message      => \@log,
1505                       affected_packages => \%affected_packages,
1506                       recipients   => \%recipients,
1507                       fixed        => [],
1508                       add          => 1,
1509                       reopen       => 0,
1510                      );
1511         };
1512         if ($@) {
1513             $errors++;
1514             print {$transcript} "Failed to set fixed on $ref: $@";
1515         }
1516
1517
1518 Sets, adds, or removes the specified fixed versions of a package
1519
1520 If the fixed versions are empty (or end up being empty after this
1521 call) or the greatest fixed version is less than the greatest found
1522 version and the reopen option is true, the bug is reopened.
1523
1524 This function is also called by the reopen function, which causes all
1525 of the fixed versions to be cleared.
1526
1527 =cut
1528
1529 sub set_fixed {
1530     my %param = validate_with(params => \@_,
1531                               spec   => {bug => {type   => SCALAR,
1532                                                  regex  => qr/^\d+$/,
1533                                                 },
1534                                          # specific options here
1535                                          fixed    => {type => SCALAR|ARRAYREF,
1536                                                       default => [],
1537                                                      },
1538                                          add      => {type => BOOLEAN,
1539                                                       default => 0,
1540                                                      },
1541                                          remove   => {type => BOOLEAN,
1542                                                       default => 0,
1543                                                      },
1544                                          reopen   => {type => BOOLEAN,
1545                                                       default => 0,
1546                                                      },
1547                                          %common_options,
1548                                          %append_action_options,
1549                                         },
1550                              );
1551     if ($param{add} and $param{remove}) {
1552         croak "It's nonsensical to add and remove the same versions";
1553     }
1554     my %info =
1555         __begin_control(%param,
1556                         command  => 'fixed'
1557                        );
1558     my ($debug,$transcript) =
1559         @info{qw(debug transcript)};
1560     my @data = @{$info{data}};
1561     my @bugs = @{$info{bugs}};
1562     my %versions;
1563     for my $version (make_list($param{fixed})) {
1564         next unless defined $version;
1565         $versions{$version} =
1566             [make_source_versions(package => [splitpackages($data[0]{package})],
1567                                   warnings => $transcript,
1568                                   debug    => $debug,
1569                                   guess_source => 0,
1570                                   versions     => $version,
1571                                  )
1572             ];
1573         # This is really ugly, but it's what we have to do
1574         if (not @{$versions{$version}}) {
1575             print {$transcript} "Unable to make a source version for version '$version'\n";
1576         }
1577     }
1578     if (not keys %versions and ($param{remove} or $param{add})) {
1579         if ($param{remove}) {
1580             print {$transcript} "Requested to remove no versions; doing nothing.\n";
1581         }
1582         else {
1583             print {$transcript} "Requested to add no versions; doing nothing.\n";
1584         }
1585         __end_control(%info);
1586         return;
1587     }
1588     # first things first, make the versions fully qualified source
1589     # versions
1590     for my $data (@data) {
1591         my $old_data = dclone($data);
1592         # The 'done' field gets a bit weird with version tracking,
1593         # because a bug may be closed by multiple people in different
1594         # branches. Until we have something more flexible, we set it
1595         # every time a bug is fixed, and clear it when a bug is found
1596         # in a version greater than any version in which the bug is
1597         # fixed or when a bug is found and there is no fixed version
1598         my $action = 'Did not alter fixed versions';
1599         my %found_added = ();
1600         my %found_removed = ();
1601         my %fixed_added = ();
1602         my %fixed_removed = ();
1603         my $reopened = 0;
1604         if (not $param{add} and not $param{remove}) {
1605             $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1606             $data->{fixed_versions} = [];
1607         }
1608         my %found_versions;
1609         @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1610         my %fixed_versions;
1611         @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1612         for my $version (keys %versions) {
1613             if ($param{add}) {
1614                 my @svers = @{$versions{$version}};
1615                 if (not @svers) {
1616                     @svers = $version;
1617                 }
1618                 for my $sver (@svers) {
1619                     if (not exists $fixed_versions{$sver}) {
1620                         $fixed_versions{$sver} = 1;
1621                         $fixed_added{$sver} = 1;
1622                     }
1623                 }
1624             }
1625             elsif ($param{remove}) {
1626                 # in the case of removal, we only concern ourself with
1627                 # the version passed, not the source version it maps
1628                 # to
1629                 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1630                 delete $fixed_versions{$_} for @temp;
1631                 $fixed_removed{$_} = 1 for @temp;
1632             }
1633             else {
1634                 # set the keys to exactly these values
1635                 my @svers = @{$versions{$version}};
1636                 if (not @svers) {
1637                     @svers = $version;
1638                 }
1639                 for my $sver (@svers) {
1640                     if (not exists $fixed_versions{$sver}) {
1641                         $fixed_versions{$sver} = 1;
1642                         if (exists $fixed_removed{$sver}) {
1643                             delete $fixed_removed{$sver};
1644                         }
1645                         else {
1646                             $fixed_added{$sver} = 1;
1647                         }
1648                     }
1649                 }
1650             }
1651         }
1652
1653         $data->{found_versions} = [keys %found_versions];
1654         $data->{fixed_versions} = [keys %fixed_versions];
1655
1656         # If we're supposed to consider reopening, reopen if the
1657         # fixed versions are empty or the greatest found version
1658         # is greater than the greatest fixed version
1659         if ($param{reopen} and defined $data->{done}
1660             and length $data->{done}) {
1661             my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1662                 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1663             # determine if we need to reopen
1664             my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1665                     map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1666             if (not @fixed_order or
1667                 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1668                 $reopened = 1;
1669                 $data->{done} = '';
1670             }
1671         }
1672
1673         my @changed;
1674         push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1675         push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1676         push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1677         push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1678         $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1679         if ($reopened) {
1680             $action .= " and reopened"
1681         }
1682         if (not $reopened and not @changed) {
1683             print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1684                 unless __internal_request();
1685             next;
1686         }
1687         $action .= '.';
1688         append_action_to_log(bug => $data->{bug_num},
1689                              command  => 'fixed',
1690                              new_data => $data,
1691                              old_data => $old_data,
1692                              get_lock => 0,
1693                              __return_append_to_log_options(
1694                                                             %param,
1695                                                             action => $action,
1696                                                            ),
1697                             )
1698             if not exists $param{append_log} or $param{append_log};
1699         writebug($data->{bug_num},$data);
1700         print {$transcript} "$action\n";
1701     }
1702     __end_control(%info);
1703 }
1704
1705
1706
1707 =head2 affects
1708
1709      eval {
1710             affects(bug          => $ref,
1711                     transcript   => $transcript,
1712                     ($dl > 0 ? (debug => $transcript):()),
1713                     requester    => $header{from},
1714                     request_addr => $controlrequestaddr,
1715                     message      => \@log,
1716                     affected_packages => \%affected_packages,
1717                     recipients   => \%recipients,
1718                     packages     => undef,
1719                     add          => 1,
1720                     remove       => 0,
1721                    );
1722         };
1723         if ($@) {
1724             $errors++;
1725             print {$transcript} "Failed to mark $ref as affecting $packages: $@";
1726         }
1727
1728 This marks a bug as affecting packages which the bug is not actually
1729 in. This should only be used in cases where fixing the bug instantly
1730 resolves the problem in the other packages.
1731
1732 By default, the packages are set to the list of packages passed.
1733 However, if you pass add => 1 or remove => 1, the list of packages
1734 passed are added or removed from the affects list, respectively.
1735
1736 =cut
1737
1738 sub affects {
1739     my %param = validate_with(params => \@_,
1740                               spec   => {bug => {type   => SCALAR,
1741                                                  regex  => qr/^\d+$/,
1742                                                 },
1743                                          # specific options here
1744                                          packages => {type => SCALAR|ARRAYREF,
1745                                                       default => [],
1746                                                      },
1747                                          add      => {type => BOOLEAN,
1748                                                       default => 0,
1749                                                      },
1750                                          remove   => {type => BOOLEAN,
1751                                                       default => 0,
1752                                                      },
1753                                          %common_options,
1754                                          %append_action_options,
1755                                         },
1756                              );
1757     if ($param{add} and $param{remove}) {
1758          croak "Asking to both add and remove affects is nonsensical";
1759     }
1760     my %info =
1761         __begin_control(%param,
1762                         command  => 'affects'
1763                        );
1764     my ($debug,$transcript) =
1765         @info{qw(debug transcript)};
1766     my @data = @{$info{data}};
1767     my @bugs = @{$info{bugs}};
1768     my $action = '';
1769     for my $data (@data) {
1770         $action = '';
1771          print {$debug} "Going to change affects\n";
1772          my @packages = splitpackages($data->{affects});
1773          my %packages;
1774          @packages{@packages} = (1) x @packages;
1775          if ($param{add}) {
1776               my @added = ();
1777               for my $package (make_list($param{packages})) {
1778                   next unless defined $package and length $package;
1779                   if (not $packages{$package}) {
1780                       $packages{$package} = 1;
1781                       push @added,$package;
1782                   }
1783               }
1784               if (@added) {
1785                    $action = "Added indication that $data->{bug_num} affects ".
1786                         english_join(\@added);
1787               }
1788          }
1789          elsif ($param{remove}) {
1790               my @removed = ();
1791               for my $package (make_list($param{packages})) {
1792                    if ($packages{$package}) {
1793                        next unless defined $package and length $package;
1794                         delete $packages{$package};
1795                         push @removed,$package;
1796                    }
1797               }
1798               $action = "Removed indication that $data->{bug_num} affects " .
1799                    english_join(\@removed);
1800          }
1801          else {
1802               my %added_packages = ();
1803               my %removed_packages = %packages;
1804               %packages = ();
1805               for my $package (make_list($param{packages})) {
1806                    next unless defined $package and length $package;
1807                    $packages{$package} = 1;
1808                    delete $removed_packages{$package};
1809                    $added_packages{$package} = 1;
1810               }
1811               if (keys %removed_packages) {
1812                   $action = "Removed indication that $data->{bug_num} affects ".
1813                       english_join([keys %removed_packages]);
1814                   $action .= "\n" if keys %added_packages;
1815               }
1816               if (keys %added_packages) {
1817                   $action .= "Added indication that $data->{bug_num} affects " .
1818                    english_join([%added_packages]);
1819               }
1820          }
1821         if (not length $action) {
1822             print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
1823                 unless __internal_request();
1824         }
1825          my $old_data = dclone($data);
1826          $data->{affects} = join(',',keys %packages);
1827          append_action_to_log(bug => $data->{bug_num},
1828                               get_lock => 0,
1829                               command => 'affects',
1830                               new_data => $data,
1831                               old_data => $old_data,
1832                               __return_append_to_log_options(
1833                                                              %param,
1834                                                              action => $action,
1835                                                             ),
1836                              )
1837                if not exists $param{append_log} or $param{append_log};
1838           writebug($data->{bug_num},$data);
1839           print {$transcript} "$action\n";
1840      }
1841     __end_control(%info);
1842 }
1843
1844
1845 =head1 SUMMARY FUNCTIONS
1846
1847 =head2 summary
1848
1849      eval {
1850             summary(bug          => $ref,
1851                     transcript   => $transcript,
1852                     ($dl > 0 ? (debug => $transcript):()),
1853                     requester    => $header{from},
1854                     request_addr => $controlrequestaddr,
1855                     message      => \@log,
1856                     affected_packages => \%affected_packages,
1857                     recipients   => \%recipients,
1858                     summary      => undef,
1859                    );
1860         };
1861         if ($@) {
1862             $errors++;
1863             print {$transcript} "Failed to mark $ref with summary foo: $@";
1864         }
1865
1866 Handles all setting of summary fields
1867
1868 If summary is undef, unsets the summary
1869
1870 If summary is 0, sets the summary to the first paragraph contained in
1871 the message passed.
1872
1873 If summary is numeric, sets the summary to the message specified.
1874
1875
1876 =cut
1877
1878
1879 sub summary {
1880     my %param = validate_with(params => \@_,
1881                               spec   => {bug => {type   => SCALAR,
1882                                                  regex  => qr/^\d+$/,
1883                                                 },
1884                                          # specific options here
1885                                          summary => {type => SCALAR|UNDEF,
1886                                                      default => 0,
1887                                                     },
1888                                          %common_options,
1889                                          %append_action_options,
1890                                         },
1891                              );
1892     croak "summary must be numeric or undef" if
1893         defined $param{summary} and not $param{summary} =~ /^\d+$/;
1894     my %info =
1895         __begin_control(%param,
1896                         command  => 'summary'
1897                        );
1898     my ($debug,$transcript) =
1899         @info{qw(debug transcript)};
1900     my @data = @{$info{data}};
1901     my @bugs = @{$info{bugs}};
1902     # figure out the log that we're going to use
1903     my $summary = '';
1904     my $summary_msg = '';
1905     my $action = '';
1906     if (not defined $param{summary}) {
1907          # do nothing
1908          print {$debug} "Removing summary fields\n";
1909          $action = 'Removed summary';
1910     }
1911     else {
1912          my $log = [];
1913          my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
1914          if ($param{summary} == 0) {
1915               $log = $param{message};
1916               $summary_msg = @records + 1;
1917          }
1918          else {
1919               if (($param{summary} - 1 ) > $#records) {
1920                    die "Message number '$param{summary}' exceeds the maximum message '$#records'";
1921               }
1922               my $record = $records[($param{summary} - 1 )];
1923               if ($record->{type} !~ /incoming-recv|recips/) {
1924                    die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
1925               }
1926               $summary_msg = $param{summary};
1927               $log = [$record->{text}];
1928          }
1929          my $p_o = Debbugs::MIME::parse(join('',@{$log}));
1930          my $body = $p_o->{body};
1931          my $in_pseudoheaders = 0;
1932          my $paragraph = '';
1933          # walk through body until we get non-blank lines
1934          for my $line (@{$body}) {
1935               if ($line =~ /^\s*$/) {
1936                    if (length $paragraph) {
1937                         if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
1938                              $paragraph = '';
1939                              next;
1940                         }
1941                         last;
1942                    }
1943                    $in_pseudoheaders = 0;
1944                    next;
1945               }
1946               # skip a paragraph if it looks like it's control or
1947               # pseudo-headers
1948               if ($line =~ m{^\s*(?:(?:Package|Source|Version)\:| #pseudo headers
1949                                  (?:package|(?:no|)owner|severity|tag|summary| #control
1950                                       reopen|close|(?:not|)(?:fixed|found)|clone|
1951                                       (?:force|)merge|user(?:category|tag|)
1952                                  )
1953                             )\s+\S}x) {
1954                    if (not length $paragraph) {
1955                         print {$debug} "Found control/pseudo-headers and skiping them\n";
1956                         $in_pseudoheaders = 1;
1957                         next;
1958                    }
1959               }
1960               next if $in_pseudoheaders;
1961               $paragraph .= $line ." \n";
1962          }
1963          print {$debug} "Summary is going to be '$paragraph'\n";
1964          $summary = $paragraph;
1965          $summary =~ s/[\n\r]/ /g;
1966          if (not length $summary) {
1967               die "Unable to find summary message to use";
1968          }
1969          # trim off a trailing spaces
1970          $summary =~ s/\ *$//;
1971     }
1972     for my $data (@data) {
1973          print {$debug} "Going to change summary\n";
1974          if (((not defined $summary or not length $summary) and
1975               (not defined $data->{summary} or not length $data->{summary})) or
1976              $summary eq $data->{summary}) {
1977              print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1978                  unless __internal_request();
1979              next;
1980          }
1981          if (length $summary) {
1982               if (length $data->{summary}) {
1983                    $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1984               }
1985               else {
1986                    $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1987               }
1988          }
1989          my $old_data = dclone($data);
1990          $data->{summary} = $summary;
1991          append_action_to_log(bug => $data->{bug_num},
1992                               command => 'summary',
1993                               old_data => $old_data,
1994                               new_data => $data,
1995                               get_lock => 0,
1996                               __return_append_to_log_options(
1997                                                              %param,
1998                                                              action => $action,
1999                                                             ),
2000                              )
2001                if not exists $param{append_log} or $param{append_log};
2002           writebug($data->{bug_num},$data);
2003           print {$transcript} "$action\n";
2004      }
2005     __end_control(%info);
2006 }
2007
2008
2009
2010
2011 =head1 OWNER FUNCTIONS
2012
2013 =head2 owner
2014
2015      eval {
2016             owner(bug          => $ref,
2017                   transcript   => $transcript,
2018                   ($dl > 0 ? (debug => $transcript):()),
2019                   requester    => $header{from},
2020                   request_addr => $controlrequestaddr,
2021                   message      => \@log,
2022                   recipients   => \%recipients,
2023                   owner        => undef,
2024                  );
2025         };
2026         if ($@) {
2027             $errors++;
2028             print {$transcript} "Failed to mark $ref as having an owner: $@";
2029         }
2030
2031 Handles all setting of the owner field; given an owner of undef or of
2032 no length, indicates that a bug is not owned by anyone.
2033
2034 =cut
2035
2036 sub owner {
2037      my %param = validate_with(params => \@_,
2038                                spec   => {bug => {type   => SCALAR,
2039                                                   regex  => qr/^\d+$/,
2040                                                  },
2041                                           owner => {type => SCALAR|UNDEF,
2042                                                    },
2043                                           %common_options,
2044                                           %append_action_options,
2045                                          },
2046                               );
2047      my %info =
2048          __begin_control(%param,
2049                          command  => 'owner',
2050                         );
2051      my ($debug,$transcript) =
2052         @info{qw(debug transcript)};
2053      my @data = @{$info{data}};
2054      my @bugs = @{$info{bugs}};
2055      my $action = '';
2056      for my $data (@data) {
2057           print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2058           print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2059           if (not defined $param{owner} or not length $param{owner}) {
2060               if (not defined $data->{owner} or not length $data->{owner}) {
2061                   print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2062                       unless __internal_request();
2063                   next;
2064               }
2065               $param{owner} = '';
2066               $action = "Removed annotation that $config{bug} was owned by " .
2067                   "$data->{owner}.";
2068           }
2069           else {
2070               if ($data->{owner} eq $param{owner}) {
2071                   print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2072                   next;
2073               }
2074               if (length $data->{owner}) {
2075                   $action = "Owner changed from $data->{owner} to $param{owner}.";
2076               }
2077               else {
2078                   $action = "Owner recorded as $param{owner}."
2079               }
2080           }
2081           my $old_data = dclone($data);
2082           $data->{owner} = $param{owner};
2083           append_action_to_log(bug => $data->{bug_num},
2084                                command => 'owner',
2085                                new_data => $data,
2086                                old_data => $old_data,
2087                                get_lock => 0,
2088                __return_append_to_log_options(
2089                                               %param,
2090                                               action => $action,
2091                                              ),
2092                               )
2093                if not exists $param{append_log} or $param{append_log};
2094           writebug($data->{bug_num},$data);
2095           print {$transcript} "$action\n";
2096      }
2097      __end_control(%info);
2098 }
2099
2100
2101 =head1 ARCHIVE FUNCTIONS
2102
2103
2104 =head2 bug_archive
2105
2106      my $error = '';
2107      eval {
2108         bug_archive(bug => $bug_num,
2109                     debug => \$debug,
2110                     transcript => \$transcript,
2111                    );
2112      };
2113      if ($@) {
2114         $errors++;
2115         transcript("Unable to archive $bug_num\n");
2116         warn $@;
2117      }
2118      transcript($transcript);
2119
2120
2121 This routine archives a bug
2122
2123 =over
2124
2125 =item bug -- bug number
2126
2127 =item check_archiveable -- check wether a bug is archiveable before
2128 archiving; defaults to 1
2129
2130 =item archive_unarchived -- whether to archive bugs which have not
2131 previously been archived; defaults to 1. [Set to 0 when used from
2132 control@]
2133
2134 =item ignore_time -- whether to ignore time constraints when archiving
2135 a bug; defaults to 0.
2136
2137 =back
2138
2139 =cut
2140
2141 sub bug_archive {
2142      my %param = validate_with(params => \@_,
2143                                spec   => {bug => {type   => SCALAR,
2144                                                   regex  => qr/^\d+$/,
2145                                                  },
2146                                           check_archiveable => {type => BOOLEAN,
2147                                                                 default => 1,
2148                                                                },
2149                                           archive_unarchived => {type => BOOLEAN,
2150                                                                  default => 1,
2151                                                                 },
2152                                           ignore_time => {type => BOOLEAN,
2153                                                           default => 0,
2154                                                          },
2155                                           %common_options,
2156                                           %append_action_options,
2157                                          },
2158                               );
2159      my %info = __begin_control(%param,
2160                                 command => 'archive',
2161                                 );
2162      my ($debug,$transcript) = @info{qw(debug transcript)};
2163      my @data = @{$info{data}};
2164      my @bugs = @{$info{bugs}};
2165      my $action = "$config{bug} archived.";
2166      if ($param{check_archiveable} and
2167          not bug_archiveable(bug=>$param{bug},
2168                              ignore_time => $param{ignore_time},
2169                             )) {
2170           print {$transcript} "Bug $param{bug} cannot be archived\n";
2171           die "Bug $param{bug} cannot be archived";
2172      }
2173      print {$debug} "$param{bug} considering\n";
2174      if (not $param{archive_unarchived} and
2175          not exists $data[0]{unarchived}
2176         ) {
2177           print {$transcript} "$param{bug} has not been archived previously\n";
2178           die "$param{bug} has not been archived previously";
2179      }
2180      add_recipients(recipients => $param{recipients},
2181                     data => \@data,
2182                     debug      => $debug,
2183                     transcript => $transcript,
2184                    );
2185      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2186      for my $bug (@bugs) {
2187          if ($param{check_archiveable}) {
2188              die "Bug $bug cannot be archived (but $param{bug} can?)"
2189                  unless bug_archiveable(bug=>$bug,
2190                                         ignore_time => $param{ignore_time},
2191                                        );
2192          }
2193      }
2194      # If we get here, we can archive/remove this bug
2195      print {$debug} "$param{bug} removing\n";
2196      for my $bug (@bugs) {
2197           #print "$param{bug} removing $bug\n" if $debug;
2198           my $dir = get_hashname($bug);
2199           # First indicate that this bug is being archived
2200           append_action_to_log(bug => $bug,
2201                                get_lock => 0,
2202                                command => 'archive',
2203                                # we didn't actually change the data
2204                                # when we archived, so we don't pass
2205                                # a real new_data or old_data
2206                                new_data => {},
2207                                old_data => {},
2208                                __return_append_to_log_options(
2209                                  %param,
2210                                  action => $action,
2211                                 )
2212                               )
2213                if not exists $param{append_log} or $param{append_log};
2214           my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2215           if ($config{save_old_bugs}) {
2216                mkpath("$config{spool_dir}/archive/$dir");
2217                foreach my $file (@files_to_remove) {
2218                    link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2219                        copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2220                            # we need to bail out here if things have
2221                            # gone horribly wrong to avoid removing a
2222                            # bug altogether
2223                            die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2224                }
2225
2226                print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2227           }
2228           unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2229           print {$transcript} "deleted $bug (from $param{bug})\n";
2230      }
2231      bughook_archive(@bugs);
2232      __end_control(%info);
2233 }
2234
2235 =head2 bug_unarchive
2236
2237      my $error = '';
2238      eval {
2239         bug_unarchive(bug => $bug_num,
2240                       debug => \$debug,
2241                       transcript => \$transcript,
2242                      );
2243      };
2244      if ($@) {
2245         $errors++;
2246         transcript("Unable to archive bug: $bug_num");
2247      }
2248      transcript($transcript);
2249
2250 This routine unarchives a bug
2251
2252 =cut
2253
2254 sub bug_unarchive {
2255      my %param = validate_with(params => \@_,
2256                                spec   => {bug => {type   => SCALAR,
2257                                                   regex  => qr/^\d+/,
2258                                                  },
2259                                           %common_options,
2260                                           %append_action_options,
2261                                          },
2262                               );
2263
2264      my %info = __begin_control(%param,
2265                                 archived=>1,
2266                                 command=>'unarchive');
2267      my ($debug,$transcript) =
2268          @info{qw(debug transcript)};
2269      my @data = @{$info{data}};
2270      my @bugs = @{$info{bugs}};
2271      my $action = "$config{bug} unarchived.";
2272      my @files_to_remove;
2273      for my $bug (@bugs) {
2274           print {$debug} "$param{bug} removing $bug\n";
2275           my $dir = get_hashname($bug);
2276           my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
2277           mkpath("archive/$dir");
2278           foreach my $file (@files_to_copy) {
2279                # die'ing here sucks
2280                link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2281                     copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2282                          die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
2283           }
2284           push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
2285           print {$transcript} "Unarchived $config{bug} $bug\n";
2286      }
2287      unlink(@files_to_remove) or die "Unable to unlink bugs";
2288      # Indicate that this bug has been archived previously
2289      for my $bug (@bugs) {
2290           my $newdata = readbug($bug);
2291           my $old_data = dclone($newdata);
2292           if (not defined $newdata) {
2293                print {$transcript} "$config{bug} $bug disappeared!\n";
2294                die "Bug $bug disappeared!";
2295           }
2296           $newdata->{unarchived} = time;
2297           append_action_to_log(bug => $bug,
2298                                get_lock => 0,
2299                                command => 'unarchive',
2300                                new_data => $newdata,
2301                                old_data => $old_data,
2302                                __return_append_to_log_options(
2303                                  %param,
2304                                  action => $action,
2305                                 )
2306                               )
2307                if not exists $param{append_log} or $param{append_log};
2308           writebug($bug,$newdata);
2309      }
2310      __end_control(%info);
2311 }
2312
2313 =head2 append_action_to_log
2314
2315      append_action_to_log
2316
2317 This should probably be moved to Debbugs::Log; have to think that out
2318 some more.
2319
2320 =cut
2321
2322 sub append_action_to_log{
2323      my %param = validate_with(params => \@_,
2324                                spec   => {bug => {type   => SCALAR,
2325                                                   regex  => qr/^\d+/,
2326                                                  },
2327                                           new_data => {type => HASHREF,
2328                                                        optional => 1,
2329                                                       },
2330                                           old_data => {type => HASHREF,
2331                                                        optional => 1,
2332                                                       },
2333                                           command  => {type => SCALAR,
2334                                                        optional => 1,
2335                                                       },
2336                                           action => {type => SCALAR,
2337                                                     },
2338                                           requester => {type => SCALAR,
2339                                                         default => '',
2340                                                        },
2341                                           request_addr => {type => SCALAR,
2342                                                            default => '',
2343                                                           },
2344                                           location => {type => SCALAR,
2345                                                        optional => 1,
2346                                                       },
2347                                           message  => {type => SCALAR|ARRAYREF,
2348                                                        default => '',
2349                                                       },
2350                                           desc       => {type => SCALAR,
2351                                                          default => '',
2352                                                         },
2353                                           get_lock   => {type => BOOLEAN,
2354                                                          default => 1,
2355                                                         },
2356                                           # we don't use
2357                                           # append_action_options here
2358                                           # because some of these
2359                                           # options aren't actually
2360                                           # optional, even though the
2361                                           # original function doesn't
2362                                           # require them
2363                                          },
2364                               );
2365      # Fix this to use $param{location}
2366      my $log_location = buglog($param{bug});
2367      die "Unable to find .log for $param{bug}"
2368           if not defined $log_location;
2369      if ($param{get_lock}) {
2370           filelock("lock/$param{bug}");
2371      }
2372      my $log = IO::File->new(">>$log_location") or
2373           die "Unable to open $log_location for appending: $!";
2374      # determine difference between old and new
2375      my $data_diff = '';
2376      if (exists $param{old_data} and exists $param{new_data}) {
2377          my $old_data = dclone($param{old_data});
2378          my $new_data = dclone($param{new_data});
2379          for my $key (keys %{$old_data}) {
2380              if (not exists $Debbugs::Status::fields{$key}) {
2381                  delete $old_data->{$key};
2382                  next;
2383              }
2384              next unless exists $new_data->{$key};
2385              next unless defined $new_data->{$key};
2386              if (not defined $old_data->{$key}) {
2387                  delete $old_data->{$key};
2388                  next;
2389              }
2390              if (ref($new_data->{$key}) and
2391                  ref($old_data->{$key}) and
2392                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
2393                 local $Storable::canonical = 1;
2394                 # print STDERR Dumper($new_data,$old_data,$key);
2395                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2396                     delete $new_data->{$key};
2397                     delete $old_data->{$key};
2398                 }
2399              }
2400              elsif ($new_data->{$key} eq $old_data->{$key}) {
2401                  delete $new_data->{$key};
2402                  delete $old_data->{$key};
2403              }
2404          }
2405          for my $key (keys %{$new_data}) {
2406              if (not exists $Debbugs::Status::fields{$key}) {
2407                  delete $new_data->{$key};
2408                  next;
2409              }
2410              next unless exists $old_data->{$key};
2411              next unless defined $old_data->{$key};
2412              if (not defined $new_data->{$key} or
2413                  not exists $Debbugs::Status::fields{$key}) {
2414                  delete $new_data->{$key};
2415                  next;
2416              }
2417              if (ref($new_data->{$key}) and
2418                  ref($old_data->{$key}) and
2419                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
2420                 local $Storable::canonical = 1;
2421                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2422                     delete $new_data->{$key};
2423                     delete $old_data->{$key};
2424                 }
2425              }
2426              elsif ($new_data->{$key} eq $old_data->{$key}) {
2427                  delete $new_data->{$key};
2428                  delete $old_data->{$key};
2429              }
2430          }
2431          $data_diff .= "<!-- new_data:\n";
2432          my %nd;
2433          for my $key (keys %{$new_data}) {
2434              if (not exists $Debbugs::Status::fields{$key}) {
2435                  warn "No such field $key";
2436                  next;
2437              }
2438              $nd{$key} = $new_data->{$key};
2439              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
2440          }
2441          $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
2442          $data_diff .= "-->\n";
2443          $data_diff .= "<!-- old_data:\n";
2444          my %od;
2445          for my $key (keys %{$old_data}) {
2446              if (not exists $Debbugs::Status::fields{$key}) {
2447                  warn "No such field $key";
2448                  next;
2449              }
2450              $od{$key} = $old_data->{$key};
2451              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
2452          }
2453          $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
2454          $data_diff .= "-->\n";
2455      }
2456      my $msg = join('',"\6\n",
2457                     (exists $param{command} ?
2458                      "<!-- command:".html_escape($param{command})." -->\n":""
2459                     ),
2460                     (length $param{requester} ?
2461                      "<!-- requester: ".html_escape($param{requester})." -->\n":""
2462                     ),
2463                     (length $param{request_addr} ?
2464                      "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
2465                     ),
2466                     "<!-- time:".time()." -->\n",
2467                     $data_diff,
2468                     "<strong>".html_escape($param{action})."</strong>\n");
2469      if (length $param{requester}) {
2470           $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
2471      }
2472      if (length $param{request_addr}) {
2473           $msg .= "to <code>".html_escape($param{request_addr})."</code>";
2474      }
2475      if (length $param{desc}) {
2476           $msg .= ":<br>\n$param{desc}\n";
2477      }
2478      else {
2479           $msg .= ".\n";
2480      }
2481      $msg .= "\3\n";
2482      if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
2483           $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
2484                or die "Unable to append to $log_location: $!";
2485      }
2486      print {$log} $msg or die "Unable to append to $log_location: $!";
2487      close $log or die "Unable to close $log_location: $!";
2488      if ($param{get_lock}) {
2489           unfilelock();
2490      }
2491
2492
2493 }
2494
2495
2496 =head1 PRIVATE FUNCTIONS
2497
2498 =head2 __handle_affected_packages
2499
2500      __handle_affected_packages(affected_packages => {},
2501                                 data => [@data],
2502                                )
2503
2504
2505
2506 =cut
2507
2508 sub __handle_affected_packages{
2509      my %param = validate_with(params => \@_,
2510                                spec   => {%common_options,
2511                                           data => {type => ARRAYREF|HASHREF
2512                                                   },
2513                                          },
2514                                allow_extra => 1,
2515                               );
2516      for my $data (make_list($param{data})) {
2517           next unless exists $data->{package} and defined $data->{package};
2518           my @packages = split /\s*,\s*/,$data->{package};
2519           @{$param{affected_packages}}{@packages} = (1) x @packages;
2520       }
2521 }
2522
2523 =head2 __handle_debug_transcript
2524
2525      my ($debug,$transcript) = __handle_debug_transcript(%param);
2526
2527 Returns a debug and transcript filehandle
2528
2529
2530 =cut
2531
2532 sub __handle_debug_transcript{
2533      my %param = validate_with(params => \@_,
2534                                spec   => {%common_options},
2535                                allow_extra => 1,
2536                               );
2537      my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
2538      my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
2539      return ($debug,$transcript);
2540 }
2541
2542 =head2 __bug_info
2543
2544      __bug_info($data)
2545
2546 Produces a small bit of bug information to kick out to the transcript
2547
2548 =cut
2549
2550 sub __bug_info{
2551      my $return = '';
2552      for my $data (@_) {
2553          next unless defined $data and exists $data->{bug_num};
2554           $return .= "Bug #".($data->{bug_num}||'').
2555               ((defined $data->{done} and length $data->{done})?
2556                 " {Done: $data->{done}}":''
2557                ).
2558                " [".($data->{package}||'(no package)'). "] ".
2559                     ($data->{subject}||'(no subject)')."\n";
2560      }
2561      return $return;
2562 }
2563
2564
2565 =head2 __internal_request
2566
2567      __internal_request()
2568      __internal_request($level)
2569
2570 Returns true if the caller of the function calling __internal_request
2571 belongs to __PACKAGE__
2572
2573 This allows us to be magical, and don't bother to print bug info if
2574 the second caller is from this package, amongst other things.
2575
2576 An optional level is allowed, which increments the number of levels to
2577 check by the given value. [This is basically for use by internal
2578 functions like __begin_control which are always called by
2579 C<__PACKAGE__>.
2580
2581 =cut
2582
2583 sub __internal_request{
2584     my ($l) = @_;
2585     $l = 0 if not defined $l;
2586     if (defined +(caller(2+$l))[0] and +(caller(2+$l))[0] eq __PACKAGE__) {
2587         return 1;
2588     }
2589     return 0;
2590 }
2591
2592 sub __return_append_to_log_options{
2593      my %param = @_;
2594      my $action = $param{action} if exists $param{action};
2595      if (not exists $param{requester}) {
2596           $param{requester} = $config{control_internal_requester};
2597      }
2598      if (not exists $param{request_addr}) {
2599           $param{request_addr} = $config{control_internal_request_addr};
2600      }
2601      if (not exists $param{message}) {
2602           my $date = rfc822_date();
2603           $param{message} = fill_in_template(template  => 'mail/fake_control_message',
2604                                              variables => {request_addr => $param{request_addr},
2605                                                            requester    => $param{requester},
2606                                                            date         => $date,
2607                                                            action       => $action
2608                                                           },
2609                                             );
2610      }
2611      if (not defined $action) {
2612           carp "Undefined action!";
2613           $action = "unknown action";
2614      }
2615      return (action => $action,
2616              (map {exists $append_action_options{$_}?($_,$param{$_}):()}
2617               keys %param),
2618             );
2619 }
2620
2621 =head2 __begin_control
2622
2623      my %info = __begin_control(%param,
2624                                 archived=>1,
2625                                 command=>'unarchive');
2626      my ($debug,$transcript) = @info{qw(debug transcript)};
2627      my @data = @{$info{data}};
2628      my @bugs = @{$info{bugs}};
2629
2630
2631 Starts the process of modifying a bug; handles all of the generic
2632 things that almost every control request needs
2633
2634 Returns a hash containing
2635
2636 =over
2637
2638 =item new_locks -- number of new locks taken out by this call
2639
2640 =item debug -- the debug file handle
2641
2642 =item transcript -- the transcript file handle
2643
2644 =item data -- an arrayref containing the data of the bugs
2645 corresponding to this request
2646
2647 =item bugs -- an arrayref containing the bug numbers of the bugs
2648 corresponding to this request
2649
2650 =back
2651
2652 =cut
2653
2654 our $locks = 0;
2655
2656 sub __begin_control {
2657     my %param = validate_with(params => \@_,
2658                               spec   => {bug => {type   => SCALAR,
2659                                                  regex  => qr/^\d+/,
2660                                                 },
2661                                          archived => {type => BOOLEAN,
2662                                                       default => 0,
2663                                                      },
2664                                          command  => {type => SCALAR,
2665                                                       optional => 1,
2666                                                      },
2667                                          %common_options,
2668                                         },
2669                               allow_extra => 1,
2670                              );
2671     my $new_locks;
2672     my ($debug,$transcript) = __handle_debug_transcript(@_);
2673     print {$debug} "$param{bug} considering\n";
2674     my @data = ();
2675     my $old_die = $SIG{__DIE__};
2676     $SIG{__DIE__} = *sig_die{CODE};
2677
2678     ($new_locks, @data) =
2679         lock_read_all_merged_bugs($param{bug},
2680                                   ($param{archived}?'archive':()));
2681     $locks += $new_locks;
2682     if (not @data) {
2683         die "Unable to read any bugs successfully.";
2684     }
2685     ###
2686     # XXX check the limit at this point, and die if it is exceeded.
2687     # This is currently not done
2688     ###
2689     __handle_affected_packages(%param,data => \@data);
2690     print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2691     print {$debug} "$param{bug} read $locks locks\n";
2692     if (not @data or not defined $data[0]) {
2693         print {$transcript} "No bug found for $param{bug}\n";
2694         die "No bug found for $param{bug}";
2695     }
2696
2697     add_recipients(data => \@data,
2698                    recipients => $param{recipients},
2699                    (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2700                    debug      => $debug,
2701                    transcript => $transcript,
2702                   );
2703
2704     print {$debug} "$param{bug} read done\n";
2705     my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2706     print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2707     return (data       => \@data,
2708             bugs       => \@bugs,
2709             old_die    => $old_die,
2710             new_locks  => $new_locks,
2711             debug      => $debug,
2712             transcript => $transcript,
2713             param      => \%param,
2714            );
2715 }
2716
2717 =head2 __end_control
2718
2719      __end_control(%info);
2720
2721 Handles tearing down from a control request
2722
2723 =cut
2724
2725 sub __end_control {
2726     my %info = @_;
2727     if (exists $info{new_locks} and $info{new_locks} > 0) {
2728         print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2729         for (1..$info{new_locks}) {
2730             unfilelock();
2731         }
2732     }
2733     $SIG{__DIE__} = $info{old_die};
2734     if (exists $info{param}{bugs_affected}) {
2735         @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2736     }
2737     add_recipients(recipients => $info{param}{recipients},
2738                    (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
2739                    data       => $info{data},
2740                    debug      => $info{debug},
2741                    transcript => $info{transcript},
2742                   );
2743     __handle_affected_packages(%{$info{param}},data=>$info{data});
2744 }
2745
2746
2747 =head2 die
2748
2749      sig_die "foo"
2750
2751 We override die to specially handle unlocking files in the cases where
2752 we are called via eval. [If we're not called via eval, it doesn't
2753 matter.]
2754
2755 =cut
2756
2757 sub sig_die{
2758     #if ($^S) { # in eval
2759         if ($locks) {
2760             for (1..$locks) { unfilelock(); }
2761             $locks = 0;
2762         }
2763     #}
2764 }
2765
2766
2767 # =head2 __message_body_template
2768 #
2769 #      message_body_template('mail/ack',{ref=>'foo'});
2770 #
2771 # Creates a message body using a template
2772 #
2773 # =cut
2774
2775 sub __message_body_template{
2776      my ($template,$extra_var) = @_;
2777      $extra_var ||={};
2778      my $hole_var = {'&bugurl' =>
2779                      sub{"$_[0]: ".
2780                              'http://'.$config{cgi_domain}.'/'.
2781                                  Debbugs::CGI::bug_url($_[0]);
2782                      }
2783                     };
2784
2785      my $body = fill_in_template(template => $template,
2786                                  variables => {config => \%config,
2787                                                %{$extra_var},
2788                                               },
2789                                  hole_var => $hole_var,
2790                                 );
2791      return fill_in_template(template => 'mail/message_body',
2792                              variables => {config => \%config,
2793                                            %{$extra_var},
2794                                            body => $body,
2795                                           },
2796                              hole_var => $hole_var,
2797                             );
2798 }
2799
2800
2801 1;
2802
2803 __END__