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.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Control;
14 Debbugs::Control -- Routines for modifying the state of bugs
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.
27 All of the public functions take the following options:
31 =item debug -- scalar reference to which debbuging information is
34 =item transcript -- scalar reference to which transcript information
37 =item affected_bugs -- hashref which is updated with bugs affected by
43 Functions which should (probably) append to the .log file take the
48 =item requester -- Email address of the individual who requested the change
50 =item request_addr -- Address to which the request was sent
52 =item location -- Optional location; currently ignored but may be
53 supported in the future for updating archived bugs upon archival
55 =item message -- The original message which caused the action to be taken
57 =item append_log -- Whether or not to append information to the log.
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.
73 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
74 use base qw(Exporter);
78 $DEBUG = 0 unless defined $DEBUG;
81 %EXPORT_TAGS = (archive => [qw(bug_archive bug_unarchive),
83 log => [qw(append_action_to_log),
87 Exporter::export_ok_tags(qw(archive log));
88 $EXPORT_TAGS{all} = [@EXPORT_OK];
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);
94 use Debbugs::CGI qw(html_escape);
95 use Debbugs::Log qw(:misc);
97 use Params::Validate qw(validate_with :types);
98 use File::Path qw(mkpath);
101 use POSIX qw(strftime);
103 # These are a set of options which are common to all of these functions
105 my %common_options = (debug => {type => SCALARREF,
108 transcript => {type => SCALARREF,
111 affected_bugs => {type => HASHREF,
117 my %append_action_options =
118 (action => {type => SCALAR,
121 requester => {type => SCALAR,
124 request_addr => {type => SCALAR,
127 location => {type => SCALAR,
130 message => {type => SCALAR|ARRAYREF,
133 append_log => {type => BOOLEAN,
135 depends => [qw(requester request_addr),
146 bug_archive(bug => $bug_num,
148 transcript => \$transcript,
153 transcript("Unable to archive $bug_num\n");
156 transcript($transcript);
159 This routine archives a bug
164 my %param = validate_with(params => \@_,
165 spec => {bug => {type => SCALAR,
168 check_archiveable => {type => BOOLEAN,
171 ignore_time => {type => BOOLEAN,
175 %append_action_options,
178 my $action = "$config{bug} archived.";
179 my ($debug,$transcript) = __handle_debug_transcript(%param);
180 if ($param{check_archiveable} and
181 not bug_archiveable(bug=>$param{bug},
182 ignore_time => $param{ignore_time},
184 print {$transcript} "Bug $param{bug} cannot be archived\n";
185 die "Bug $param{bug} cannot be archived";
187 print {$debug} "$param{bug} considering\n";
188 my ($locks, $data) = lockreadbugmerge($param{bug});
189 print {$debug} "$param{bug} read $locks\n";
190 defined $data or die "No bug found for $param{bug}";
191 print {$debug} "$param{bug} read ok (done $data->{done})\n";
192 print {$debug} "$param{bug} read done\n";
193 my @bugs = ($param{bug});
195 # @bugs{@bugs} = (1) x @bugs;
196 if (length($data->{mergedwith})) {
197 push(@bugs,split / /,$data->{mergedwith});
199 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
200 for my $bug (@bugs) {
202 print {$debug} "$param{bug} $bug check\n";
203 if ($bug != $param{bug}) {
204 print {$debug} "$param{bug} $bug reading\n";
205 $newdata = lockreadbug($bug) || die "huh $bug ?";
206 print {$debug} "$param{bug} $bug read ok\n";
211 print {$debug} "$param{bug} $bug read/not\n";
212 my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
213 $newdata->{mergedwith} eq $expectmerge ||
214 die "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
215 print {$debug} "$param{bug} $bug merge-ok\n";
216 if ($param{check_archiveable}) {
217 die "Bug $bug cannot be archived (but $param{bug} can?)"
218 unless bug_archiveable(bug=>$bug,
219 ignore_time => $param{ignore_time},
223 # If we get here, we can archive/remove this bug
224 print {$debug} "$param{bug} removing\n";
225 for my $bug (@bugs) {
226 #print "$param{bug} removing $bug\n" if $debug;
227 my $dir = get_hashname($bug);
228 # First indicate that this bug is being archived
229 append_action_to_log(bug => $bug,
231 __return_append_to_log_options(
232 (map {exists $param{$_}?($_,$param{$_}):()}
233 keys %append_action_options,
238 if not exists $param{append_log} or $param{append_log};
239 my @files_to_remove = map {s#db-h/$dir/##; $_} glob("db-h/$dir/$bug.*");
240 if ($config{save_old_bugs}) {
241 mkpath("archive/$dir");
242 foreach my $file (@files_to_remove) {
243 link( "db-h/$dir/$file", "archive/$dir/$file" ) || copy( "db-h/$dir/$file", "archive/$dir/$file" );
246 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
248 unlink(map {"db-h/$dir/$_"} @files_to_remove);
249 print {$transcript} "deleted $bug (from $param{bug})\n";
251 bughook_archive(@bugs);
252 if (exists $param{bugs_affected}) {
253 @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
255 print {$debug} "$param{bug} unlocking $locks\n";
257 for (1..$locks) { unfilelock(); }
259 print {$debug} "$param{bug} unlocking done\n";
266 bug_unarchive(bug => $bug_num,
268 transcript => \$transcript,
273 transcript("Unable to archive bug: $bug_num");
275 transcript($transcript);
277 This routine unarchives a bug
282 my %param = validate_with(params => \@_,
283 spec => {bug => {type => SCALAR,
287 %append_action_options,
290 my $action = "$config{bug} unarchived.";
291 my ($debug,$transcript) = __handle_debug_transcript(%param);
292 print {$debug} "$param{bug} considering\n";
293 my ($locks, $data) = lockreadbugmerge($param{bug},'archive');
294 print {$debug} "$param{bug} read $locks\n";
295 if (not defined $data) {
296 print {$transcript} "No bug found for $param{bug}\n";
297 die "No bug found for $param{bug}";
299 print {$debug} "$param{bug} read ok (done $data->{done})\n";
300 print {$debug} "$param{bug} read done\n";
301 my @bugs = ($param{bug});
303 # @bugs{@bugs} = (1) x @bugs;
304 if (length($data->{mergedwith})) {
305 push(@bugs,split / /,$data->{mergedwith});
307 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
308 for my $bug (@bugs) {
310 print {$debug} "$param{bug} $bug check\n";
311 if ($bug != $param{bug}) {
312 print {$debug} "$param{bug} $bug reading\n";
313 $newdata = lockreadbug($bug,'archive') or die "huh $bug ?";
314 print {$debug} "$param{bug} $bug read ok\n";
319 print {$debug} "$param{bug} $bug read/not\n";
320 my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
321 if ($newdata->{mergedwith} ne $expectmerge ) {
322 print {$transcript} "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (@bugs)";
323 die "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (@bugs)";
325 print {$debug} "$param{bug} $bug merge-ok\n";
327 # If we get here, we can archive/remove this bug
328 print {$debug} "$param{bug} removing\n";
330 for my $bug (@bugs) {
331 print {$debug} "$param{bug} removing $bug\n";
332 my $dir = get_hashname($bug);
333 my @files_to_copy = map {s#archive/$dir/##; $_} glob("archive/$dir/$bug.*");
334 mkpath("archive/$dir");
335 foreach my $file (@files_to_copy) {
337 link( "archive/$dir/$file", "db-h/$dir/$file" ) or
338 copy( "archive/$dir/$file", "db-h/$dir/$file" ) or
339 die "Unable to copy archive/$dir/$file to db-h/$dir/$file";
341 push @files_to_remove, map {"archive/$dir/$_"} @files_to_copy;
342 print {$transcript} "Unarchived $config{bug} $bug\n";
344 unlink(@files_to_remove) or die "Unable to unlink bugs";
345 # Indicate that this bug has been archived previously
346 for my $bug (@bugs) {
347 my $newdata = readbug($bug);
348 if (not defined $newdata) {
349 print {$transcript} "$config{bug} $bug disappeared!\n";
350 die "Bug $bug disappeared!";
352 $newdata->{unarchived} = time;
353 append_action_to_log(bug => $bug,
355 __return_append_to_log_options(
356 (map {exists $param{$_}?($_,$param{$_}):()}
357 keys %append_action_options,
362 if not exists $param{append_log} or $param{append_log};
363 writebug($bug,$newdata);
365 print {$debug} "$param{bug} unlocking $locks\n";
367 for (1..$locks) { unfilelock(); };
369 if (exists $param{bugs_affected}) {
370 @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
372 print {$debug} "$param{bug} unlocking done\n";
375 =head2 append_action_to_log
379 This should probably be moved to Debbugs::Log; have to think that out
384 sub append_action_to_log{
385 my %param = validate_with(params => \@_,
386 spec => {bug => {type => SCALAR,
389 action => {type => SCALAR,
391 requester => {type => SCALAR,
393 request_addr => {type => SCALAR,
395 location => {type => SCALAR,
398 message => {type => SCALAR|ARRAYREF,
400 get_lock => {type => BOOLEAN,
405 # Fix this to use $param{location}
406 my $log_location = buglog($param{bug});
407 die "Unable to find .log for $param{bug}"
408 if not defined $log_location;
409 if ($param{get_lock}) {
410 filelock("lock/$param{bug}");
412 my $log = IO::File->new(">>$log_location") or
413 die "Unable to open $log_location for appending: $!";
415 "<!-- time:".time." -->\n".
416 "<strong>".html_escape($param{action})."</strong>\n".
417 "Request was from <code>".html_escape($param{requester})."</code>\n".
418 "to <code>".html_escape($param{request_addr})."</code>. \n".
420 "\7\n",escape_log(make_list($param{message})),"\n\3\n"
421 or die "Unable to append to $log_location: $!";
422 close $log or die "Unable to close $log_location: $!";
423 if ($param{get_lock}) {
431 =head1 PRIVATE FUNCTIONS
433 =head2 __handle_debug_transcript
435 my ($debug,$transcript) = __handle_debug_transcript(%param);
437 Returns a debug and transcript IO::Scalar filehandle
442 sub __handle_debug_transcript{
443 my %param = validate_with(params => \@_,
444 spec => {%common_options},
448 my $debug = IO::Scalar->new(exists $param{debug}?$param{debug}:\$fake_scalar);
449 my $transcript = IO::Scalar->new(exists $param{transcript}?$param{transcript}:\$fake_scalar);
450 return ($debug,$transcript);
454 sub __return_append_to_log_options{
456 my $action = 'Unknown action';
457 if (not exists $param{requester}) {
458 $param{requester} = $config{control_internal_requester};
460 if (not exists $param{request_addr}) {
461 $param{request_addr} = $config{control_internal_request_addr};
463 if (not exists $param{message}) {
464 $action = $param{action} if exists $param{action};
465 my $date = strftime "%a, %d %h %Y %T +0000", gmtime;
466 $param{message} = <<END;
467 Received: (at fakecontrol) by fakecontrolmessage;
468 To: $param{request_addr}
469 From: $param{requester}
470 Subject: Internal Control
473 User-Agent: Fakemail v42.6.9
476 # A log time ago, in a galaxy far, far away
477 # something happened.
479 # Magically this resulted in the following
480 # action being taken, but this fake control
481 # message doesn't tell you why it happened
486 # This fakemail brought to you by your local debbugs
490 return (action => $action,