Debbugs/Control.pm

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