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 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 = (archive => [qw(bug_archive bug_unarchive),
  82                                 ],
  83                      log     => [qw(append_action_to_log),
  84                                 ],
  85                     );
  86      @EXPORT_OK = ();
  87      Exporter::export_ok_tags(qw(archive log));
  88      $EXPORT_TAGS{all} = [@EXPORT_OK];
  89 }
  90
  91 use Debbugs::Config qw(:config);
  92 use Debbugs::Common qw(:lock buglog make_list get_hashname);
  93 use Debbugs::Status qw(bug_archiveable :read :hook writebug);
  94 use Debbugs::CGI qw(html_escape);
  95 use Debbugs::Log qw(:misc);
  96
  97 use Params::Validate qw(validate_with :types);
  98 use File::Path qw(mkpath);
  99 use IO::File;
 100 use IO::Scalar;
 101
 102 use POSIX qw(strftime);
 103
 104 # These are a set of options which are common to all of these functions
 105
 106 my %common_options = (debug       => {type => SCALARREF,
 107                                       optional => 1,
 108                                      },
 109                       transcript  => {type => SCALARREF,
 110                                       optional => 1,
 111                                      },
 112                       affected_bugs => {type => HASHREF,
 113                                         optional => 1,
 114                                        },
 115                      );
 116
 117
 118 my %append_action_options =
 119      (action => {type => SCALAR,
 120                  optional => 1,
 121                 },
 122       requester => {type => SCALAR,
 123                     optional => 1,
 124                    },
 125       request_addr => {type => SCALAR,
 126                        optional => 1,
 127                       },
 128       location => {type => SCALAR,
 129                    optional => 1,
 130                   },
 131       message  => {type => SCALAR|ARRAYREF,
 132                    optional => 1,
 133                   },
 134       append_log => {type => BOOLEAN,
 135                      optional => 1,
 136                      depends => [qw(requester request_addr),
 137                                  qw(message),
 138                                 ],
 139                     },
 140      );
 141
 142
 143 =head2 bug_archive
 144
 145      my $error = '';
 146      eval {
 147         bug_archive(bug => $bug_num,
 148                     debug => \$debug,
 149                     transcript => \$transcript,
 150                    );
 151      };
 152      if ($@) {
 153         $errors++;
 154         transcript("Unable to archive $bug_num\n");
 155         warn $@;
 156      }
 157      transcript($transcript);
 158
 159
 160 This routine archives a bug
 161
 162 =cut
 163
 164 sub bug_archive {
 165      my %param = validate_with(params => \@_,
 166                                spec   => {bug => {type   => SCALAR,
 167                                                   regex  => qr/^\d+$/,
 168                                                  },
 169                                           check_archiveable => {type => BOOLEAN,
 170                                                                 default => 1,
 171                                                                },
 172                                           ignore_time => {type => BOOLEAN,
 173                                                           default => 0,
 174                                                          },
 175                                           %common_options,
 176                                           %append_action_options,
 177                                          },
 178                               );
 179      our $locks = 0;
 180      local $SIG{__DIE__} = sub {
 181           if ($locks) {
 182                for (1..$locks) { unfilelock(); }
 183                $locks = 0;
 184           }
 185      };
 186      my $action = "$config{bug} archived.";
 187      my ($debug,$transcript) = __handle_debug_transcript(%param);
 188      if ($param{check_archiveable} and
 189          not bug_archiveable(bug=>$param{bug},
 190                              ignore_time => $param{ignore_time},
 191                             )) {
 192           print {$transcript} "Bug $param{bug} cannot be archived\n";
 193           die "Bug $param{bug} cannot be archived";
 194      }
 195      print {$debug} "$param{bug} considering\n";
 196      my ($data);
 197      ($locks, $data) = lockreadbugmerge($param{bug});
 198      print {$debug} "$param{bug} read $locks\n";
 199      defined $data or die "No bug found for $param{bug}";
 200      print {$debug} "$param{bug} read ok (done $data->{done})\n";
 201      print {$debug} "$param{bug} read done\n";
 202      my @bugs = ($param{bug});
 203      # my %bugs;
 204      # @bugs{@bugs} = (1) x @bugs;
 205      if (length($data->{mergedwith})) {
 206           push(@bugs,split / /,$data->{mergedwith});
 207      }
 208      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
 209      for my $bug (@bugs) {
 210           my $newdata;
 211           print {$debug} "$param{bug} $bug check\n";
 212           if ($bug != $param{bug}) {
 213                print {$debug} "$param{bug} $bug reading\n";
 214                $newdata = lockreadbug($bug) || die "huh $bug ?";
 215                print {$debug} "$param{bug} $bug read ok\n";
 216                $locks++;
 217           } else {
 218                $newdata = $data;
 219           }
 220           print {$debug} "$param{bug} $bug read/not\n";
 221           my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
 222           $newdata->{mergedwith} eq $expectmerge ||
 223                die "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
 224           print {$debug} "$param{bug} $bug merge-ok\n";
 225           if ($param{check_archiveable}) {
 226                die "Bug $bug cannot be archived (but $param{bug} can?)"
 227                     unless bug_archiveable(bug=>$bug,
 228                                            ignore_time => $param{ignore_time},
 229                                           );
 230           }
 231      }
 232      # If we get here, we can archive/remove this bug
 233      print {$debug} "$param{bug} removing\n";
 234      for my $bug (@bugs) {
 235           #print "$param{bug} removing $bug\n" if $debug;
 236           my $dir = get_hashname($bug);
 237           # First indicate that this bug is being archived
 238           append_action_to_log(bug => $bug,
 239                                get_lock => 0,
 240                                __return_append_to_log_options(
 241                                  (map {exists $param{$_}?($_,$param{$_}):()}
 242                                   keys %append_action_options,
 243                                  ),
 244                                  action => $action,
 245                                 )
 246                               )
 247                if not exists $param{append_log} or $param{append_log};
 248           my @files_to_remove = map {s#db-h/$dir/##; $_} glob("db-h/$dir/$bug.*");
 249           if ($config{save_old_bugs}) {
 250                mkpath("archive/$dir");
 251                foreach my $file (@files_to_remove) {
 252                     link( "db-h/$dir/$file", "archive/$dir/$file" ) || copy( "db-h/$dir/$file", "archive/$dir/$file" );
 253                }
 254
 255                print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
 256           }
 257           unlink(map {"db-h/$dir/$_"} @files_to_remove);
 258           print {$transcript} "deleted $bug (from $param{bug})\n";
 259      }
 260      bughook_archive(@bugs);
 261      if (exists $param{bugs_affected}) {
 262           @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
 263      }
 264      print {$debug} "$param{bug} unlocking $locks\n";
 265      if ($locks) {
 266           for (1..$locks) { unfilelock(); }
 267      }
 268      print {$debug} "$param{bug} unlocking done\n";
 269 }
 270
 271 =head2 bug_unarchive
 272
 273      my $error = '';
 274      eval {
 275         bug_unarchive(bug => $bug_num,
 276                       debug => \$debug,
 277                       transcript => \$transcript,
 278                      );
 279      };
 280      if ($@) {
 281         $errors++;
 282         transcript("Unable to archive bug: $bug_num");
 283      }
 284      transcript($transcript);
 285
 286 This routine unarchives a bug
 287
 288 =cut
 289
 290 sub bug_unarchive {
 291      my %param = validate_with(params => \@_,
 292                                spec   => {bug => {type   => SCALAR,
 293                                                   regex  => qr/^\d+/,
 294                                                  },
 295                                           %common_options,
 296                                           %append_action_options,
 297                                          },
 298                               );
 299      my $action = "$config{bug} unarchived.";
 300      my ($debug,$transcript) = __handle_debug_transcript(%param);
 301      print {$debug} "$param{bug} considering\n";
 302      my ($locks, $data) = lockreadbugmerge($param{bug},'archive');
 303      print {$debug} "$param{bug} read $locks\n";
 304      if (not defined $data) {
 305           print {$transcript} "No bug found for $param{bug}\n";
 306           die "No bug found for $param{bug}";
 307      }
 308      print {$debug} "$param{bug} read ok (done $data->{done})\n";
 309      print {$debug} "$param{bug} read done\n";
 310      my @bugs = ($param{bug});
 311      # my %bugs;
 312      # @bugs{@bugs} = (1) x @bugs;
 313      if (length($data->{mergedwith})) {
 314           push(@bugs,split / /,$data->{mergedwith});
 315      }
 316      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
 317      for my $bug (@bugs) {
 318           my $newdata;
 319           print {$debug} "$param{bug} $bug check\n";
 320           if ($bug != $param{bug}) {
 321                print {$debug} "$param{bug} $bug reading\n";
 322                $newdata = lockreadbug($bug,'archive') or die "huh $bug ?";
 323                print {$debug} "$param{bug} $bug read ok\n";
 324                $locks++;
 325           } else {
 326                $newdata = $data;
 327           }
 328           print {$debug} "$param{bug} $bug read/not\n";
 329           my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
 330           if ($newdata->{mergedwith} ne $expectmerge ) {
 331                print {$transcript} "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (@bugs)";
 332                die "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (@bugs)";
 333           }
 334           print {$debug} "$param{bug} $bug merge-ok\n";
 335      }
 336      # If we get here, we can archive/remove this bug
 337      print {$debug} "$param{bug} removing\n";
 338      my @files_to_remove;
 339      for my $bug (@bugs) {
 340           print {$debug} "$param{bug} removing $bug\n";
 341           my $dir = get_hashname($bug);
 342           my @files_to_copy = map {s#archive/$dir/##; $_} glob("archive/$dir/$bug.*");
 343           mkpath("archive/$dir");
 344           foreach my $file (@files_to_copy) {
 345                # die'ing here sucks
 346                link( "archive/$dir/$file", "db-h/$dir/$file" ) or
 347                     copy( "archive/$dir/$file", "db-h/$dir/$file" ) or
 348                          die "Unable to copy archive/$dir/$file to db-h/$dir/$file";
 349           }
 350           push @files_to_remove, map {"archive/$dir/$_"} @files_to_copy;
 351           print {$transcript} "Unarchived $config{bug} $bug\n";
 352      }
 353      unlink(@files_to_remove) or die "Unable to unlink bugs";
 354      # Indicate that this bug has been archived previously
 355      for my $bug (@bugs) {
 356           my $newdata = readbug($bug);
 357           if (not defined $newdata) {
 358                print {$transcript} "$config{bug} $bug disappeared!\n";
 359                die "Bug $bug disappeared!";
 360           }
 361           $newdata->{unarchived} = time;
 362           append_action_to_log(bug => $bug,
 363                                get_lock => 0,
 364                                __return_append_to_log_options(
 365                                  (map {exists $param{$_}?($_,$param{$_}):()}
 366                                   keys %append_action_options,
 367                                  ),
 368                                  action => $action,
 369                                 )
 370                               )
 371                if not exists $param{append_log} or $param{append_log};
 372           writebug($bug,$newdata);
 373      }
 374      print {$debug} "$param{bug} unlocking $locks\n";
 375      if ($locks) {
 376           for (1..$locks) { unfilelock(); };
 377      }
 378      if (exists $param{bugs_affected}) {
 379           @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
 380      }
 381      print {$debug} "$param{bug} unlocking done\n";
 382 }
 383
 384 =head2 append_action_to_log
 385
 386      append_action_to_log
 387
 388 This should probably be moved to Debbugs::Log; have to think that out
 389 some more.
 390
 391 =cut
 392
 393 sub append_action_to_log{
 394      my %param = validate_with(params => \@_,
 395                                spec   => {bug => {type   => SCALAR,
 396                                                   regex  => qr/^\d+/,
 397                                                  },
 398                                           action => {type => SCALAR,
 399                                                     },
 400                                           requester => {type => SCALAR,
 401                                                        },
 402                                           request_addr => {type => SCALAR,
 403                                                           },
 404                                           location => {type => SCALAR,
 405                                                        optional => 1,
 406                                                       },
 407                                           message  => {type => SCALAR|ARRAYREF,
 408                                                       },
 409                                           get_lock   => {type => BOOLEAN,
 410                                                          default => 1,
 411                                                         },
 412                                          }
 413                               );
 414      # Fix this to use $param{location}
 415      my $log_location = buglog($param{bug});
 416      die "Unable to find .log for $param{bug}"
 417           if not defined $log_location;
 418      if ($param{get_lock}) {
 419           filelock("lock/$param{bug}");
 420      }
 421      my $log = IO::File->new(">>$log_location") or
 422           die "Unable to open $log_location for appending: $!";
 423      print {$log} "\6\n".
 424           "<!-- time:".time." -->\n".
 425           "<strong>".html_escape($param{action})."</strong>\n".
 426           "Request was from <code>".html_escape($param{requester})."</code>\n".
 427           "to <code>".html_escape($param{request_addr})."</code>. \n".
 428           "\3\n".
 429           "\7\n",escape_log(make_list($param{message})),"\n\3\n"
 430                or die "Unable to append to $log_location: $!";
 431      close $log or die "Unable to close $log_location: $!";
 432      if ($param{get_lock}) {
 433           unlockfile();
 434      }
 435
 436
 437 }
 438
 439
 440 =head1 PRIVATE FUNCTIONS
 441
 442 =head2 __handle_debug_transcript
 443
 444      my ($debug,$transcript) = __handle_debug_transcript(%param);
 445
 446 Returns a debug and transcript IO::Scalar filehandle
 447
 448
 449 =cut
 450
 451 sub __handle_debug_transcript{
 452      my %param = validate_with(params => \@_,
 453                                spec   => {%common_options},
 454                                allow_extra => 1,
 455                               );
 456      my $fake_scalar;
 457      my $debug = IO::Scalar->new(exists $param{debug}?$param{debug}:\$fake_scalar);
 458      my $transcript = IO::Scalar->new(exists $param{transcript}?$param{transcript}:\$fake_scalar);
 459      return ($debug,$transcript);
 460
 461 }
 462
 463 sub __return_append_to_log_options{
 464      my %param = @_;
 465      my $action = 'Unknown action';
 466      if (not exists $param{requester}) {
 467           $param{requester} = $config{control_internal_requester};
 468      }
 469      if (not exists $param{request_addr}) {
 470           $param{request_addr} = $config{control_internal_request_addr};
 471      }
 472      if (not exists $param{message}) {
 473           $action = $param{action} if exists $param{action};
 474           my $date = strftime "%a, %d %h %Y %T +0000", gmtime;
 475           $param{message} = <<END;
 476 Received: (at fakecontrol) by fakecontrolmessage;
 477 To: $param{request_addr}
 478 From: $param{requester}
 479 Subject: Internal Control
 480 Message-Id: $action
 481 Date: $date
 482 User-Agent: Fakemail v42.6.9
 483
 484 # A New Hope
 485 # A log time ago, in a galaxy far, far away
 486 # something happened.
 487 #
 488 # Magically this resulted in the following
 489 # action being taken, but this fake control
 490 # message doesn't tell you why it happened
 491 #
 492 # The action:
 493 # $action
 494 thanks
 495 # This fakemail brought to you by your local debbugs
 496 # administrator
 497 END
 498      }
 499      return (action => $action,
 500              %param);
 501 }
 502
 503
 504 1;
 505
 506 __END__