Debbugs/Control.pm

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