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