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 = (summary => [qw(summary)],
  82                      owner   => [qw(owner)],
  83                      archive => [qw(bug_archive bug_unarchive),
  84                                 ],
  85                      log     => [qw(append_action_to_log),
  86                                 ],
  87                     );
  88      @EXPORT_OK = ();
  89      Exporter::export_ok_tags(keys %EXPORT_TAGS);
  90      $EXPORT_TAGS{all} = [@EXPORT_OK];
  91 }
  92
  93 use Debbugs::Config qw(:config);
  94 use Debbugs::Common qw(:lock buglog :misc get_hashname);
  95 use Debbugs::Status qw(bug_archiveable :read :hook writebug);
  96 use Debbugs::CGI qw(html_escape);
  97 use Debbugs::Log qw(:misc);
  98 use Debbugs::Recipients qw(:add);
  99
 100 use Params::Validate qw(validate_with :types);
 101 use File::Path qw(mkpath);
 102 use IO::File;
 103
 104 use Debbugs::Text qw(:templates);
 105
 106 use Debbugs::Mail qw(rfc822_date);
 107
 108 use POSIX qw(strftime);
 109
 110 use Carp;
 111
 112 # These are a set of options which are common to all of these functions
 113
 114 my %common_options = (debug       => {type => SCALARREF|HANDLE,
 115                                       optional => 1,
 116                                      },
 117                       transcript  => {type => SCALARREF|HANDLE,
 118                                       optional => 1,
 119                                      },
 120                       affected_bugs => {type => HASHREF,
 121                                         optional => 1,
 122                                        },
 123                       affected_packages => {type => HASHREF,
 124                                             optional => 1,
 125                                            },
 126                       recipients    => {type => HASHREF,
 127                                         default => {},
 128                                        },
 129                       limit         => {type => HASHREF,
 130                                         default => {},
 131                                        },
 132                      );
 133
 134
 135 my %append_action_options =
 136      (action => {type => SCALAR,
 137                  optional => 1,
 138                 },
 139       requester => {type => SCALAR,
 140                     optional => 1,
 141                    },
 142       request_addr => {type => SCALAR,
 143                        optional => 1,
 144                       },
 145       location => {type => SCALAR,
 146                    optional => 1,
 147                   },
 148       message  => {type => SCALAR|ARRAYREF,
 149                    optional => 1,
 150                   },
 151       append_log => {type => BOOLEAN,
 152                      optional => 1,
 153                      depends => [qw(requester request_addr),
 154                                  qw(message),
 155                                 ],
 156                     },
 157      );
 158
 159
 160 # this is just a generic stub for Debbugs::Control functions.
 161 # sub foo {
 162 #     my %param = validate_with(params => \@_,
 163 #                             spec   => {bug => {type   => SCALAR,
 164 #                                                regex  => qr/^\d+$/,
 165 #                                               },
 166 #                                        # specific options here
 167 #                                        %common_options,
 168 #                                        %append_action_options,
 169 #                                       },
 170 #                            );
 171 #     our $locks = 0;
 172 #     $locks = 0;
 173 #     local $SIG{__DIE__} = sub {
 174 #       if ($locks) {
 175 #           for (1..$locks) { unfilelock(); }
 176 #           $locks = 0;
 177 #       }
 178 #     };
 179 #     my ($debug,$transcript) = __handle_debug_transcript(%param);
 180 #     my (@data);
 181 #     ($locks, @data) = lock_read_all_merged_bugs($param{bug});
 182 #     __handle_affected_packages(data => \@data,%param);
 183 #     add_recipients(data => \@data,
 184 #                    recipients => $param{recipients}
 185 #                   );
 186 # }
 187
 188 =head1 SUMMARY FUNCTIONS
 189
 190 =head2 summary
 191
 192      eval {
 193             summary(bug          => $ref,
 194                     transcript   => $transcript,
 195                     ($dl > 0 ? (debug => $transcript):()),
 196                     requester    => $header{from},
 197                     request_addr => $controlrequestaddr,
 198                     message      => \@log,
 199                     affected_packages => \%affected_packages,
 200                     recipients   => \%recipients,
 201                     summary      => undef,
 202                    );
 203         };
 204         if ($@) {
 205             $errors++;
 206             print {$transcript} "Failed to mark $ref with summary foo: $@";
 207         }
 208
 209 Handles all setting of summary fields
 210
 211 If summary is undef, unsets the summary
 212
 213 If summary is 0, sets the summary to the first paragraph contained in
 214 the message passed.
 215
 216 If summary is numeric, sets the summary to the message specified.
 217
 218
 219 =cut
 220
 221
 222 sub summary {
 223     my %param = validate_with(params => \@_,
 224                               spec   => {bug => {type   => SCALAR,
 225                                                  regex  => qr/^\d+$/,
 226                                                 },
 227                                          # specific options here
 228                                          summary => {type => SCALAR|UNDEF,
 229                                                      default => 0,
 230                                                     },
 231                                          %common_options,
 232                                          %append_action_options,
 233                                         },
 234                              );
 235     croak "summary must be numeric or undef" if
 236          defined $param{summary} and not $param{summary} =~ /^\d+$/;
 237     our $locks = 0;
 238     $locks = 0;
 239     local $SIG{__DIE__} = sub {
 240         if ($locks) {
 241             for (1..$locks) { unfilelock(); }
 242             $locks = 0;
 243         }
 244     };
 245     my ($debug,$transcript) = __handle_debug_transcript(%param);
 246     my (@data);
 247     ($locks, @data) = lock_read_all_merged_bugs($param{bug});
 248     __handle_affected_packages(data => \@data,%param);
 249     add_recipients(data => \@data,
 250                    recipients => $param{recipients}
 251                   );
 252     # figure out the log that we're going to use
 253     my $summary = '';
 254     my $summary_msg = '';
 255     my $action = '';
 256     if (not defined $param{summary}) {
 257          # do nothing
 258          print {$debug} "Removing summary fields";
 259          $action = 'Removed summary';
 260     }
 261     else {
 262          my $log = [];
 263          my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
 264          if ($param{summary} == 0) {
 265               $log = $param{log};
 266               $summary_msg = @records + 1;
 267          }
 268          else {
 269               if (($param{summary} - 1 ) > $#records) {
 270                    die "Message number '$param{summary}' exceeds the maximum message '$#records'";
 271               }
 272               my $record = $records[($param{summary} - 1 )];
 273               if ($record->{type} !~ /incoming-recv|recips/) {
 274                    die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
 275               }
 276               $summary_msg = $param{summary};
 277               $log = [$record->{text}];
 278          }
 279          my $p_o = Debbugs::MIME::parse(join('',@{$log}));
 280          my $body = $p_o->{body};
 281          my $in_pseudoheaders = 0;
 282          my $paragraph = '';
 283          # walk through body until we get non-blank lines
 284          for my $line (@{$body}) {
 285               if ($line =~ /^\s*$/) {
 286                    if (length $paragraph) {
 287                         last;
 288                    }
 289                    $in_pseudoheaders = 0;
 290                    next;
 291               }
 292               # skip a paragraph if it looks like it's control or
 293               # pseudo-headers
 294               if ($line =~ m{^\s*(?:(?:Package|Source|Version)\:| #pseudo headers
 295                                  (?:package|(?:no|)owner|severity|tag|summary| #control
 296                                       reopen|close|(?:not|)(?:fixed|found)|clone|
 297                                       (?:force|)merge|user(?:category|tag|)
 298                                  )
 299                             )\s+\S}x) {
 300                    if (not length $paragraph) {
 301                         print {$debug} "Found control/pseudo-headers and skiping them\n";
 302                         $in_pseudoheaders = 1;
 303                         next;
 304                    }
 305               }
 306               next if $in_pseudoheaders;
 307               $paragraph .= $line;
 308          }
 309          print {$debug} "Summary is going to be '$paragraph'\n";
 310          $summary = $paragraph;
 311          $summary =~ s/[\n\r]//g;
 312          if (not length $summary) {
 313               die "Unable to find summary message to use";
 314          }
 315     }
 316     for my $data (@data) {
 317          print {$debug} "Going to change summary";
 318          if (length $summary) {
 319               if (length $data->{summary}) {
 320                    $action = "Summary replaced with message bug $param{bug} message $summary_msg";
 321               }
 322               else {
 323                    $action = "Summary recorded from message bug $param{bug} message $summary_msg";
 324               }
 325          }
 326          $data->{summary} = $summary;
 327          append_action_to_log(bug => $data->{bug_num},
 328                               get_lock => 0,
 329                               __return_append_to_log_options(
 330                                                              %param,
 331                                                              action => $action,
 332                                                             ),
 333                              )
 334                if not exists $param{append_log} or $param{append_log};
 335           writebug($data->{bug_num},$data);
 336           print {$transcript} "$action\n";
 337           add_recipients(data => $data,
 338                          recipients => $param{recipients},
 339                         );
 340      }
 341      if ($locks) {
 342           for (1..$locks) { unfilelock(); }
 343      }
 344
 345 }
 346
 347
 348
 349
 350 =head1 OWNER FUNCTIONS
 351
 352 =head2 owner
 353
 354      eval {
 355             owner(bug          => $ref,
 356                   transcript   => $transcript,
 357                   ($dl > 0 ? (debug => $transcript):()),
 358                   requester    => $header{from},
 359                   request_addr => $controlrequestaddr,
 360                   message      => \@log,
 361                   recipients   => \%recipients,
 362                   owner        => undef,
 363                  );
 364         };
 365         if ($@) {
 366             $errors++;
 367             print {$transcript} "Failed to mark $ref as having an owner: $@";
 368         }
 369
 370 Handles all setting of the owner field; given an owner of undef or of
 371 no length, indicates that a bug is not owned by anyone.
 372
 373 =cut
 374
 375 sub owner {
 376      my %param = validate_with(params => \@_,
 377                                spec   => {bug => {type   => SCALAR,
 378                                                   regex  => qr/^\d+$/,
 379                                                  },
 380                                           owner => {type => SCALAR|UNDEF,
 381                                                    },
 382                                           %common_options,
 383                                           %append_action_options,
 384                                          },
 385                               );
 386      our $locks = 0;
 387      $locks = 0;
 388      local $SIG{__DIE__} = sub {
 389           if ($locks) {
 390                for (1..$locks) { unfilelock(); }
 391                $locks = 0;
 392           }
 393      };
 394      my ($debug,$transcript) = __handle_debug_transcript(%param);
 395      my (@data);
 396      ($locks, @data) = lock_read_all_merged_bugs($param{bug});
 397      __handle_affected_packages(data => \@data,%param);
 398      @data and defined $data[0] or die "No bug found for $param{bug}";
 399      add_recipients(data => \@data,
 400                     recipients => $param{recipients}
 401                    );
 402      my $action = '';
 403      for my $data (@data) {
 404           print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
 405           print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
 406           if (not defined $param{owner} or not length $param{owner}) {
 407                $param{owner} = '';
 408                $action = "Removed annotation that $config{bug} was owned by " .
 409                     "$data->{owner}.";
 410           }
 411           else {
 412                if (length $data->{owner}) {
 413                     $action = "Owner changed from $data->{owner} to $param{owner}.";
 414                }
 415                else {
 416                     $action = "Owner recorded as $param{owner}."
 417                }
 418           }
 419           $data->{owner} = $param{owner};
 420           append_action_to_log(bug => $data->{bug_num},
 421                                get_lock => 0,
 422                __return_append_to_log_options(
 423                                               %param,
 424                                               action => $action,
 425                                              ),
 426                               )
 427                if not exists $param{append_log} or $param{append_log};
 428           writebug($data->{bug_num},$data);
 429           print {$transcript} "$action\n";
 430           add_recipients(data => $data,
 431                          recipients => $param{recipients},
 432                         );
 433      }
 434      if ($locks) {
 435           for (1..$locks) { unfilelock(); }
 436      }
 437 }
 438
 439
 440 =head1 ARCHIVE FUNCTIONS
 441
 442
 443 =head2 bug_archive
 444
 445      my $error = '';
 446      eval {
 447         bug_archive(bug => $bug_num,
 448                     debug => \$debug,
 449                     transcript => \$transcript,
 450                    );
 451      };
 452      if ($@) {
 453         $errors++;
 454         transcript("Unable to archive $bug_num\n");
 455         warn $@;
 456      }
 457      transcript($transcript);
 458
 459
 460 This routine archives a bug
 461
 462 =over
 463
 464 =item bug -- bug number
 465
 466 =item check_archiveable -- check wether a bug is archiveable before
 467 archiving; defaults to 1
 468
 469 =item archive_unarchived -- whether to archive bugs which have not
 470 previously been archived; defaults to 1. [Set to 0 when used from
 471 control@]
 472
 473 =item ignore_time -- whether to ignore time constraints when archiving
 474 a bug; defaults to 0.
 475
 476 =back
 477
 478 =cut
 479
 480 sub bug_archive {
 481      my %param = validate_with(params => \@_,
 482                                spec   => {bug => {type   => SCALAR,
 483                                                   regex  => qr/^\d+$/,
 484                                                  },
 485                                           check_archiveable => {type => BOOLEAN,
 486                                                                 default => 1,
 487                                                                },
 488                                           archive_unarchived => {type => BOOLEAN,
 489                                                                  default => 1,
 490                                                                 },
 491                                           ignore_time => {type => BOOLEAN,
 492                                                           default => 0,
 493                                                          },
 494                                           %common_options,
 495                                           %append_action_options,
 496                                          },
 497                               );
 498      our $locks = 0;
 499      $locks = 0;
 500      local $SIG{__DIE__} = sub {
 501           if ($locks) {
 502                for (1..$locks) { unfilelock(); }
 503                $locks = 0;
 504           }
 505      };
 506      my $action = "$config{bug} archived.";
 507      my ($debug,$transcript) = __handle_debug_transcript(%param);
 508      if ($param{check_archiveable} and
 509          not bug_archiveable(bug=>$param{bug},
 510                              ignore_time => $param{ignore_time},
 511                             )) {
 512           print {$transcript} "Bug $param{bug} cannot be archived\n";
 513           die "Bug $param{bug} cannot be archived";
 514      }
 515      print {$debug} "$param{bug} considering\n";
 516      my (@data);
 517      ($locks, @data) = lock_read_all_merged_bugs($param{bug});
 518      __handle_affected_packages(data => \@data,%param);
 519      print {$debug} "$param{bug} read $locks\n";
 520      @data and defined $data[0] or die "No bug found for $param{bug}";
 521      print {$debug} "$param{bug} read done\n";
 522
 523      if (not $param{archive_unarchived} and
 524          not exists $data[0]{unarchived}
 525         ) {
 526           print {$transcript} "$param{bug} has not been archived previously\n";
 527           die "$param{bug} has not been archived previously";
 528      }
 529      add_recipients(recipients => $param{recipients},
 530                     data => \@data,
 531                    );
 532      my @bugs = map {$_->{bug_num}} @data;
 533      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
 534      for my $bug (@bugs) {
 535          if ($param{check_archiveable}) {
 536              die "Bug $bug cannot be archived (but $param{bug} can?)"
 537                  unless bug_archiveable(bug=>$bug,
 538                                         ignore_time => $param{ignore_time},
 539                                        );
 540          }
 541      }
 542      # If we get here, we can archive/remove this bug
 543      print {$debug} "$param{bug} removing\n";
 544      for my $bug (@bugs) {
 545           #print "$param{bug} removing $bug\n" if $debug;
 546           my $dir = get_hashname($bug);
 547           # First indicate that this bug is being archived
 548           append_action_to_log(bug => $bug,
 549                                get_lock => 0,
 550                                __return_append_to_log_options(
 551                                  %param,
 552                                  action => $action,
 553                                 )
 554                               )
 555                if not exists $param{append_log} or $param{append_log};
 556           my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
 557           if ($config{save_old_bugs}) {
 558                mkpath("$config{spool_dir}/archive/$dir");
 559                foreach my $file (@files_to_remove) {
 560                     link( "$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file" ) or
 561                          copy( "$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file" );
 562                }
 563
 564                print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
 565           }
 566           unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
 567           print {$transcript} "deleted $bug (from $param{bug})\n";
 568      }
 569      bughook_archive(@bugs);
 570      if (exists $param{bugs_affected}) {
 571           @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
 572      }
 573      print {$debug} "$param{bug} unlocking $locks\n";
 574      if ($locks) {
 575           for (1..$locks) { unfilelock(); }
 576      }
 577      print {$debug} "$param{bug} unlocking done\n";
 578 }
 579
 580 =head2 bug_unarchive
 581
 582      my $error = '';
 583      eval {
 584         bug_unarchive(bug => $bug_num,
 585                       debug => \$debug,
 586                       transcript => \$transcript,
 587                      );
 588      };
 589      if ($@) {
 590         $errors++;
 591         transcript("Unable to archive bug: $bug_num");
 592      }
 593      transcript($transcript);
 594
 595 This routine unarchives a bug
 596
 597 =cut
 598
 599 sub bug_unarchive {
 600      my %param = validate_with(params => \@_,
 601                                spec   => {bug => {type   => SCALAR,
 602                                                   regex  => qr/^\d+/,
 603                                                  },
 604                                           %common_options,
 605                                           %append_action_options,
 606                                          },
 607                               );
 608      our $locks = 0;
 609      local $SIG{__DIE__} = sub {
 610           if ($locks) {
 611                for (1..$locks) { unfilelock(); }
 612                $locks = 0;
 613           }
 614      };
 615      my $action = "$config{bug} unarchived.";
 616      my ($debug,$transcript) = __handle_debug_transcript(%param);
 617      print {$debug} "$param{bug} considering\n";
 618      my @data = ();
 619      ($locks, @data) = lock_read_all_merged_bugs($param{bug},'archive');
 620      __handle_affected_packages(data => \@data,%param);
 621      print {$debug} "$param{bug} read $locks\n";
 622      if (not @data or not defined $data[0]) {
 623          print {$transcript} "No bug found for $param{bug}\n";
 624          die "No bug found for $param{bug}";
 625      }
 626      print {$debug} "$param{bug} read done\n";
 627      my @bugs = map {$_->{bug_num}} @data;
 628      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
 629      print {$debug} "$param{bug} unarchiving\n";
 630      my @files_to_remove;
 631      for my $bug (@bugs) {
 632           print {$debug} "$param{bug} removing $bug\n";
 633           my $dir = get_hashname($bug);
 634           my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
 635           mkpath("archive/$dir");
 636           foreach my $file (@files_to_copy) {
 637                # die'ing here sucks
 638                link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
 639                     copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
 640                          die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
 641           }
 642           push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
 643           print {$transcript} "Unarchived $config{bug} $bug\n";
 644      }
 645      unlink(@files_to_remove) or die "Unable to unlink bugs";
 646      # Indicate that this bug has been archived previously
 647      for my $bug (@bugs) {
 648           my $newdata = readbug($bug);
 649           if (not defined $newdata) {
 650                print {$transcript} "$config{bug} $bug disappeared!\n";
 651                die "Bug $bug disappeared!";
 652           }
 653           $newdata->{unarchived} = time;
 654           append_action_to_log(bug => $bug,
 655                                get_lock => 0,
 656                                __return_append_to_log_options(
 657                                  %param,
 658                                  action => $action,
 659                                 )
 660                               )
 661                if not exists $param{append_log} or $param{append_log};
 662           writebug($bug,$newdata);
 663           add_recipients(recipients => $param{recipients},
 664                          data       => $newdata,
 665                         );
 666      }
 667      print {$debug} "$param{bug} unlocking $locks\n";
 668      if ($locks) {
 669           for (1..$locks) { unfilelock(); };
 670      }
 671      if (exists $param{bugs_affected}) {
 672           @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
 673      }
 674      print {$debug} "$param{bug} unlocking done\n";
 675 }
 676
 677 =head2 append_action_to_log
 678
 679      append_action_to_log
 680
 681 This should probably be moved to Debbugs::Log; have to think that out
 682 some more.
 683
 684 =cut
 685
 686 sub append_action_to_log{
 687      my %param = validate_with(params => \@_,
 688                                spec   => {bug => {type   => SCALAR,
 689                                                   regex  => qr/^\d+/,
 690                                                  },
 691                                           action => {type => SCALAR,
 692                                                     },
 693                                           requester => {type => SCALAR,
 694                                                        },
 695                                           request_addr => {type => SCALAR,
 696                                                           },
 697                                           location => {type => SCALAR,
 698                                                        optional => 1,
 699                                                       },
 700                                           message  => {type => SCALAR|ARRAYREF,
 701                                                       },
 702                                           get_lock   => {type => BOOLEAN,
 703                                                          default => 1,
 704                                                         },
 705                                          }
 706                               );
 707      # Fix this to use $param{location}
 708      my $log_location = buglog($param{bug});
 709      die "Unable to find .log for $param{bug}"
 710           if not defined $log_location;
 711      if ($param{get_lock}) {
 712           filelock("lock/$param{bug}");
 713      }
 714      my $log = IO::File->new(">>$log_location") or
 715           die "Unable to open $log_location for appending: $!";
 716      print {$log} "\6\n".
 717           "<!-- time:".time." -->\n".
 718           "<strong>".html_escape($param{action})."</strong>\n".
 719           "Request was from <code>".html_escape($param{requester})."</code>\n".
 720           "to <code>".html_escape($param{request_addr})."</code>. \n".
 721           "\3\n".
 722           "\7\n",escape_log(make_list($param{message})),"\n\3\n"
 723                or die "Unable to append to $log_location: $!";
 724      close $log or die "Unable to close $log_location: $!";
 725      if ($param{get_lock}) {
 726           unlockfile();
 727      }
 728
 729
 730 }
 731
 732
 733 =head1 PRIVATE FUNCTIONS
 734
 735 =head2 __handle_affected_packages
 736
 737      __handle_affected_packages(affected_packages => {},
 738                                 data => [@data],
 739                                )
 740
 741
 742
 743 =cut
 744
 745 sub __handle_affected_packages{
 746      my %param = validate_with(params => \@_,
 747                                spec   => {%common_options,
 748                                           data => {type => ARRAYREF|HASHREF
 749                                                   },
 750                                          },
 751                                allow_extra => 1,
 752                               );
 753      for my $data (make_list($param{data})) {
 754           $param{affected_packages}{$data->{package}} = 1;
 755      }
 756 }
 757
 758 =head2 __handle_debug_transcript
 759
 760      my ($debug,$transcript) = __handle_debug_transcript(%param);
 761
 762 Returns a debug and transcript filehandle
 763
 764
 765 =cut
 766
 767 sub __handle_debug_transcript{
 768      my %param = validate_with(params => \@_,
 769                                spec   => {%common_options},
 770                                allow_extra => 1,
 771                               );
 772      my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
 773      my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
 774      return ($debug,$transcript);
 775 }
 776
 777 sub __return_append_to_log_options{
 778      my %param = @_;
 779      my $action = $param{action} if exists $param{action};
 780      if (not exists $param{requester}) {
 781           $param{requester} = $config{control_internal_requester};
 782      }
 783      if (not exists $param{request_addr}) {
 784           $param{request_addr} = $config{control_internal_request_addr};
 785      }
 786      if (not exists $param{message}) {
 787           my $date = rfc822_date();
 788           $param{message} = fill_in_template(template  => 'mail/fake_control_message',
 789                                              variables => {request_addr => $param{request_addr},
 790                                                            requester    => $param{requester},
 791                                                            date         => $date,
 792                                                            action       => $action
 793                                                           },
 794                                             );
 795      }
 796      if (not defined $action) {
 797           carp "Undefined action!";
 798           $action = "unknown action";
 799      }
 800      return (action => $action,
 801              (map {exists $append_action_options{$_}?($_,$param{$_}):()}
 802               keys %param),
 803             );
 804 }
 805
 806
 807 1;
 808
 809 __END__