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 # These are a set of options which are common to all of these functions
103 my %common_options = (debug => {type => SCALARREF,
106 transcript => {type => SCALARREF,
109 affected_bugs => {type => HASHREF,
115 my %append_action_options =
116 (action => {type => SCALAR,
119 requester => {type => SCALAR,
122 request_addr => {type => SCALAR,
125 location => {type => SCALAR,
128 message => {type => SCALAR|ARRAYREF,
131 append_log => {type => BOOLEAN,
133 depends => [qw(requester request_addr),
144 bug_archive(bug => $bug_num,
146 transcript => \$transcript,
151 transcript("Unable to archive $bug_num\n");
154 transcript($transcript);
157 This routine archives a bug
162 my %param = validate_with(params => \@_,
163 spec => {bug => {type => SCALAR,
166 check_archiveable => {type => BOOLEAN,
169 ignore_time => {type => BOOLEAN,
173 %append_action_options,
176 my $action = "$config{bug} archived.";
177 my ($debug,$transcript) = __handle_debug_transcript(%param);
178 if ($param{check_archiveable} and
179 not bug_archiveable(bug=>$param{bug},
180 ignore_time => $param{ignore_time},
182 print {$transcript} "Bug $param{bug} cannot be archived\n";
183 die "Bug $param{bug} cannot be archived";
185 print {$debug} "$param{bug} considering\n";
186 my ($locks, $data) = lockreadbugmerge($param{bug});
187 print {$debug} "$param{bug} read $locks\n";
188 defined $data or die "No bug found for $param{bug}";
189 print {$debug} "$param{bug} read ok (done $data->{done})\n";
190 print {$debug} "$param{bug} read done\n";
191 my @bugs = ($param{bug});
193 # @bugs{@bugs} = (1) x @bugs;
194 if (length($data->{mergedwith})) {
195 push(@bugs,split / /,$data->{mergedwith});
197 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
198 for my $bug (@bugs) {
200 print {$debug} "$param{bug} $bug check\n";
201 if ($bug != $param{bug}) {
202 print {$debug} "$param{bug} $bug reading\n";
203 $newdata = lockreadbug($bug) || die "huh $bug ?";
204 print {$debug} "$param{bug} $bug read ok\n";
209 print {$debug} "$param{bug} $bug read/not\n";
210 my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
211 $newdata->{mergedwith} eq $expectmerge ||
212 die "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
213 print {$debug} "$param{bug} $bug merge-ok\n";
214 if ($param{check_archiveable}) {
215 die "Bug $bug cannot be archived (but $param{bug} can?)"
216 unless bug_archiveable(bug=>$bug,
217 ignore_time => $param{ignore_time},
221 # If we get here, we can archive/remove this bug
222 print {$debug} "$param{bug} removing\n";
223 for my $bug (@bugs) {
224 #print "$param{bug} removing $bug\n" if $debug;
225 my $dir = get_hashname($bug);
226 # First indicate that this bug is being archived
227 append_action_to_log(bug => $bug,
229 __return_append_to_log_options(
230 (map {exists $param{$_}?($_,$param{$_}):()}
231 keys %append_action_options,
236 if not exists $param{append_log} or $param{append_log};
237 my @files_to_remove = map {s#db-h/$dir/##; $_} glob("db-h/$dir/$bug.*");
238 if ($config{save_old_bugs}) {
239 mkpath("archive/$dir");
240 foreach my $file (@files_to_remove) {
241 link( "db-h/$dir/$file", "archive/$dir/$file" ) || copy( "db-h/$dir/$file", "archive/$dir/$file" );
244 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
246 unlink(map {"db-h/$dir/$_"} @files_to_remove);
247 print {$transcript} "deleted $bug (from $param{bug})\n";
249 bughook_archive(@bugs);
250 if (exists $param{bugs_affected}) {
251 @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
253 print {$debug} "$param{bug} unlocking $locks\n";
255 for (1..$locks) { unfilelock(); }
257 print {$debug} "$param{bug} unlocking done\n";
264 bug_unarchive(bug => $bug_num,
266 transcript => \$transcript,
271 transcript("Unable to archive bug: $bug_num");
273 transcript($transcript);
275 This routine unarchives a bug
280 my %param = validate_with(params => \@_,
281 spec => {bug => {type => SCALAR,
285 %append_action_options,
288 my $action = "$config{bug} unarchived.";
289 my ($debug,$transcript) = __handle_debug_transcript(%param);
290 print {$debug} "$param{bug} considering\n";
291 my ($locks, $data) = lockreadbugmerge($param{bug},'archive');
292 print {$debug} "$param{bug} read $locks\n";
293 if (not defined $data) {
294 print {$transcript} "No bug found for $param{bug}\n";
295 die "No bug found for $param{bug}";
297 print {$debug} "$param{bug} read ok (done $data->{done})\n";
298 print {$debug} "$param{bug} read done\n";
299 my @bugs = ($param{bug});
301 # @bugs{@bugs} = (1) x @bugs;
302 if (length($data->{mergedwith})) {
303 push(@bugs,split / /,$data->{mergedwith});
305 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
306 for my $bug (@bugs) {
308 print {$debug} "$param{bug} $bug check\n";
309 if ($bug != $param{bug}) {
310 print {$debug} "$param{bug} $bug reading\n";
311 $newdata = lockreadbug($bug,'archive') or die "huh $bug ?";
312 print {$debug} "$param{bug} $bug read ok\n";
317 print {$debug} "$param{bug} $bug read/not\n";
318 my $expectmerge= join(' ',grep($_ != $bug, sort { $a <=> $b } @bugs));
319 if ($newdata->{mergedwith} ne $expectmerge ) {
320 print {$transcript} "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (@bugs)";
321 die "$param{bug} differs from $bug: ($newdata->{mergedwith}) vs. ($expectmerge) (@bugs)";
323 print {$debug} "$param{bug} $bug merge-ok\n";
325 # If we get here, we can archive/remove this bug
326 print {$debug} "$param{bug} removing\n";
328 for my $bug (@bugs) {
329 print {$debug} "$param{bug} removing $bug\n";
330 my $dir = get_hashname($bug);
331 my @files_to_copy = map {s#archive/$dir/##; $_} glob("archive/$dir/$bug.*");
332 mkpath("archive/$dir");
333 foreach my $file (@files_to_copy) {
335 link( "archive/$dir/$file", "db-h/$dir/$file" ) or
336 copy( "archive/$dir/$file", "db-h/$dir/$file" ) or
337 die "Unable to copy archive/$dir/$file to db-h/$dir/$file";
339 push @files_to_remove, map {"archive/$dir/$_"} @files_to_copy;
340 print {$transcript} "Unarchived $config{bug} $bug\n";
342 unlink(@files_to_remove) or die "Unable to unlink bugs";
343 # Indicate that this bug has been archived previously
344 for my $bug (@bugs) {
345 my $newdata = readbug($bug);
346 if (not defined $newdata) {
347 print {$transcript} "$config{bug} $bug disappeared!\n";
348 die "Bug $bug disappeared!";
350 $newdata->{unarchived} = time;
351 append_action_to_log(bug => $bug,
353 __return_append_to_log_options(
354 (map {exists $param{$_}?($_,$param{$_}):()}
355 keys %append_action_options,
360 if not exists $param{append_log} or $param{append_log};
361 writebug($bug,$newdata);
363 print {$debug} "$param{bug} unlocking $locks\n";
365 for (1..$locks) { unfilelock(); };
367 if (exists $param{bugs_affected}) {
368 @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
370 print {$debug} "$param{bug} unlocking done\n";
373 =head2 append_action_to_log
377 This should probably be moved to Debbugs::Log; have to think that out
382 sub append_action_to_log{
383 my %param = validate_with(params => \@_,
384 spec => {bug => {type => SCALAR,
387 action => {type => SCALAR,
389 requester => {type => SCALAR,
391 request_addr => {type => SCALAR,
393 location => {type => SCALAR,
396 message => {type => SCALAR|ARRAYREF,
398 get_lock => {type => BOOLEAN,
403 # Fix this to use $param{location}
404 my $log_location = buglog($param{bug});
405 die "Unable to find .log for $param{bug}"
406 if not defined $log_location;
407 if ($param{get_lock}) {
408 filelock("lock/$param{bug}");
410 my $log = IO::File->new(">>$log_location") or
411 die "Unable to open $log_location for appending: $!";
413 "<!-- time:".time." -->\n".
414 "<strong>".html_escape($param{action})."</strong>\n".
415 "Request was from <code>".html_escape($param{requester})."</code>\n".
416 "to <code>".html_escape($param{request_addr})."</code>. \n".
418 "\7\n",escape_log(make_list($param{message})),"\n\3\n"
419 or die "Unable to append to $log_location: $!";
420 close $log or die "Unable to close $log_location: $!";
421 if ($param{get_lock}) {
429 =head1 PRIVATE FUNCTIONS
431 =head2 __handle_debug_transcript
433 my ($debug,$transcript) = __handle_debug_transcript(%param);
435 Returns a debug and transcript IO::Scalar filehandle
440 sub __handle_debug_transcript{
441 my %param = validate_with(params => \@_,
442 spec => {%common_options},
446 my $debug = IO::Scalar->new(exists $param{debug}?$param{debug}:\$fake_scalar);
447 my $transcript = IO::Scalar->new(exists $param{transcript}?$param{transcript}:\$fake_scalar);
448 return ($debug,$transcript);
452 sub __return_append_to_log_options{
454 my $action = 'Unknown action';
455 if (not exists $param{requester}) {
456 $param{requester} = $config{control_internal_requester};
458 if (not exists $param{request_addr}) {
459 $param{request_addr} = $config{control_internal_request_addr};
461 if (not exists $param{message}) {
462 $action = $param{action} if exists $param{action};
463 $param{message} = <<END;
464 Received: (at fakecontrol) by fakecontrolmessage;
465 To: $param{request_addr}
466 From: $param{requester}
467 Subject: Internal Control
469 User-Agent: Fakemail v42.6.9
472 # A log time ago, in a galaxy far, far away
473 # something happened.
475 # Magically this resulted in the following
476 # action being taken, but this fake control
477 # message doesn't tell you why it happened
482 # This fakemail brought to you by your local debbugs
486 return (action => $action,