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