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,2008,2009 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 request_nn -- Name of queue file which caused this request
54 =item request_msgid -- Message id of message which caused this request
56 =item location -- Optional location; currently ignored but may be
57 supported in the future for updating archived bugs upon archival
59 =item message -- The original message which caused the action to be taken
61 =item append_log -- Whether or not to append information to the log.
65 B<append_log> (for most functions) is a special option. When set to
66 false, no appending to the log is done at all. When it is not present,
67 the above information is faked, and appended to the log file. When it
68 is true, the above options must be present, and their values are used.
71 =head1 GENERAL FUNCTIONS
77 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
78 use base qw(Exporter);
82 $DEBUG = 0 unless defined $DEBUG;
85 %EXPORT_TAGS = (done => [qw(set_done)],
86 submitter => [qw(set_submitter)],
87 severity => [qw(set_severity)],
88 affects => [qw(affects)],
89 summary => [qw(summary)],
91 title => [qw(set_title)],
92 forward => [qw(set_forwarded)],
93 found => [qw(set_found set_fixed)],
94 fixed => [qw(set_found set_fixed)],
95 package => [qw(set_package)],
96 block => [qw(set_blocks)],
97 merge => [qw(set_merged)],
99 clone => [qw(clone_bug)],
100 archive => [qw(bug_archive bug_unarchive),
102 log => [qw(append_action_to_log),
106 Exporter::export_ok_tags(keys %EXPORT_TAGS);
107 $EXPORT_TAGS{all} = [@EXPORT_OK];
110 use Debbugs::Config qw(:config);
111 use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions);
112 use Debbugs::Status qw(bug_archiveable :read :hook writebug new_bug splitpackages split_status_fields get_bug_status);
113 use Debbugs::CGI qw(html_escape);
114 use Debbugs::Log qw(:misc :write);
115 use Debbugs::Recipients qw(:add);
116 use Debbugs::Packages qw(:versions :mapping);
118 use Data::Dumper qw();
119 use Params::Validate qw(validate_with :types);
120 use File::Path qw(mkpath);
121 use File::Copy qw(copy);
124 use Debbugs::Text qw(:templates);
126 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
127 use Debbugs::MIME qw(create_mime_message);
129 use Mail::RFC822::Address qw();
131 use POSIX qw(strftime);
133 use Storable qw(dclone nfreeze);
134 use List::Util qw(first max);
138 # These are a set of options which are common to all of these functions
140 my %common_options = (debug => {type => SCALARREF|HANDLE,
143 transcript => {type => SCALARREF|HANDLE,
146 affected_bugs => {type => HASHREF,
149 affected_packages => {type => HASHREF,
152 recipients => {type => HASHREF,
155 limit => {type => HASHREF,
158 show_bug_info => {type => BOOLEAN,
161 request_subject => {type => SCALAR,
162 default => 'Unknown Subject',
164 request_msgid => {type => SCALAR,
167 request_nn => {type => SCALAR,
170 request_replyto => {type => SCALAR,
173 locks => {type => HASHREF,
179 my %append_action_options =
180 (action => {type => SCALAR,
183 requester => {type => SCALAR,
186 request_addr => {type => SCALAR,
189 location => {type => SCALAR,
192 message => {type => SCALAR|ARRAYREF,
195 append_log => {type => BOOLEAN,
197 depends => [qw(requester request_addr),
201 # locks is both an append_action option, and a common option;
202 # it's ok for it to be in both places.
203 locks => {type => HASHREF,
211 # this is just a generic stub for Debbugs::Control functions.
216 # set_foo(bug => $ref,
217 # transcript => $transcript,
218 # ($dl > 0 ? (debug => $transcript):()),
219 # requester => $header{from},
220 # request_addr => $controlrequestaddr,
222 # affected_packages => \%affected_packages,
223 # recipients => \%recipients,
229 # print {$transcript} "Failed to set foo $ref bar: $@";
237 # my %param = validate_with(params => \@_,
238 # spec => {bug => {type => SCALAR,
239 # regex => qr/^\d+$/,
241 # # specific options here
243 # %append_action_options,
247 # __begin_control(%param,
250 # my ($debug,$transcript) =
251 # @info{qw(debug transcript)};
252 # my @data = @{$info{data}};
253 # my @bugs = @{$info{bugs}};
256 # for my $data (@data) {
257 # append_action_to_log(bug => $data->{bug_num},
259 # __return_append_to_log_options(
264 # if not exists $param{append_log} or $param{append_log};
265 # writebug($data->{bug_num},$data);
266 # print {$transcript} "$action\n";
268 # __end_control(%info);
275 set_block(bug => $ref,
276 transcript => $transcript,
277 ($dl > 0 ? (debug => $transcript):()),
278 requester => $header{from},
279 request_addr => $controlrequestaddr,
281 affected_packages => \%affected_packages,
282 recipients => \%recipients,
288 print {$transcript} "Failed to set blockers of $ref: $@";
291 Alters the set of bugs that block this bug from being fixed
293 This requires altering both this bug (and those it's merged with) as
294 well as the bugs that block this bug from being fixed (and those that
299 =item block -- scalar or arrayref of blocking bugs to set, add or remove
301 =item add -- if true, add blocking bugs
303 =item remove -- if true, remove blocking bugs
310 my %param = validate_with(params => \@_,
311 spec => {bug => {type => SCALAR,
314 # specific options here
315 block => {type => SCALAR|ARRAYREF,
318 add => {type => BOOLEAN,
321 remove => {type => BOOLEAN,
325 %append_action_options,
328 if ($param{add} and $param{remove}) {
329 croak "It's nonsensical to add and remove the same blocking bugs";
331 if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
332 croak "Invalid blocking bug(s):".
333 join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
339 elsif ($param{remove}) {
344 __begin_control(%param,
347 my ($debug,$transcript) =
348 @info{qw(debug transcript)};
349 my @data = @{$info{data}};
350 my @bugs = @{$info{bugs}};
353 # The first bit of this code is ugly, and should be cleaned up.
354 # Its purpose is to populate %removed_blockers and %add_blockers
355 # with all of the bugs that should be added or removed as blockers
356 # of all of the bugs which are merged with $param{bug}
359 for my $blocker (make_list($param{block})) {
360 next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
361 my $data = read_bug(bug=>$blocker,
363 if (defined $data and not $data->{archive}) {
364 $data = split_status_fields($data);
365 $ok_blockers{$blocker} = 1;
367 push @merged_bugs, make_list($data->{mergedwith});
368 @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
371 $bad_blockers{$blocker} = 1;
375 # throw an error if we are setting the blockers and there is a bad
377 if (keys %bad_blockers and $mode eq 'set') {
378 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
379 keys %ok_blockers?'':" and no known blocking bug(s)";
381 # if there are no ok blockers and we are not setting the blockers,
383 if (not keys %ok_blockers and $mode ne 'set') {
384 print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
385 if (keys %bad_blockers) {
386 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
388 __end_control(%info);
392 my @change_blockers = keys %ok_blockers;
394 my %removed_blockers;
397 my @blockers = map {split ' ', $_->{blockedby}} @data;
399 @blockers{@blockers} = (1) x @blockers;
401 # it is nonsensical for a bug to block itself (or a merged
402 # partner); We currently don't allow removal because we'd possibly
406 @bugs{@bugs} = (1) x @bugs;
407 for my $blocker (@change_blockers) {
408 if ($bugs{$blocker}) {
409 croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
412 @blockers = keys %blockers;
414 %removed_blockers = ();
415 for my $blocker (@change_blockers) {
416 next if exists $blockers{$blocker};
417 $blockers{$blocker} = 1;
418 $added_blockers{$blocker} = 1;
421 elsif ($param{remove}) {
422 %added_blockers = ();
423 for my $blocker (@change_blockers) {
424 next if exists $removed_blockers{$blocker};
425 delete $blockers{$blocker};
426 $removed_blockers{$blocker} = 1;
430 @removed_blockers{@blockers} = (1) x @blockers;
432 for my $blocker (@change_blockers) {
433 next if exists $blockers{$blocker};
434 $blockers{$blocker} = 1;
435 if (exists $removed_blockers{$blocker}) {
436 delete $removed_blockers{$blocker};
439 $added_blockers{$blocker} = 1;
443 my @new_blockers = keys %blockers;
444 for my $data (@data) {
445 my $old_data = dclone($data);
446 # remove blockers and/or add new ones as appropriate
447 if ($data->{blockedby} eq '') {
448 print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n";
450 print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n";
452 if ($data->{blocks} eq '') {
453 print {$transcript} "$data->{bug_num} was not blocking any bugs.\n";
455 print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n";
458 push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
459 push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers;
460 $action = ucfirst(join ('; ',@changed)) if @changed;
462 print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n"
463 unless __internal_request();
466 $data->{blockedby} = join(' ',keys %blockers);
467 append_action_to_log(bug => $data->{bug_num},
469 old_data => $old_data,
472 __return_append_to_log_options(
477 if not exists $param{append_log} or $param{append_log};
478 writebug($data->{bug_num},$data);
479 print {$transcript} "$action\n";
481 # we do this bit below to avoid code duplication
483 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
484 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
486 for my $add_remove (keys %mungable_blocks) {
490 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
491 next if $munge_blockers{$blocker};
492 my ($temp_locks, @blocking_data) =
493 lock_read_all_merged_bugs(bug => $blocker,
494 ($param{archived}?(location => 'archive'):()),
495 exists $param{locks}?(locks => $param{locks}):(),
497 $locks+= $temp_locks;
498 $new_locks+=$temp_locks;
499 if (not @blocking_data) {
500 for (1..$new_locks) {
501 unfilelock(exists $param{locks}?$param{locks}:());
504 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
506 for (map {$_->{bug_num}} @blocking_data) {
507 $munge_blockers{$_} = 1;
509 for my $data (@blocking_data) {
510 my $old_data = dclone($data);
512 my @blocks = split ' ', $data->{blocks};
513 @blocks{@blocks} = (1) x @blocks;
515 for my $bug (@bugs) {
516 if ($add_remove eq 'remove') {
517 next unless exists $blocks{$bug};
518 delete $blocks{$bug};
521 next if exists $blocks{$bug};
526 $data->{blocks} = join(' ',sort keys %blocks);
527 my $action = ($add_remove eq 'add'?'Added':'Removed').
528 " indication that bug $data->{bug_num} blocks ".
530 append_action_to_log(bug => $data->{bug_num},
532 old_data => $old_data,
535 __return_append_to_log_options(%param,
539 writebug($data->{bug_num},$data);
541 __handle_affected_packages(%param,data=>\@blocking_data);
542 add_recipients(recipients => $param{recipients},
543 actions_taken => {blocks => 1},
544 data => \@blocking_data,
546 transcript => $transcript,
549 for (1..$new_locks) {
550 unfilelock(exists $param{locks}?$param{locks}:());
555 __end_control(%info);
564 transcript => $transcript,
565 ($dl > 0 ? (debug => $transcript):()),
566 requester => $header{from},
567 request_addr => $controlrequestaddr,
569 affected_packages => \%affected_packages,
570 recipients => \%recipients,
577 print {$transcript} "Failed to set tag on $ref: $@";
581 Sets, adds, or removes the specified tags on a bug
585 =item tag -- scalar or arrayref of tags to set, add or remove
587 =item add -- if true, add tags
589 =item remove -- if true, remove tags
591 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
599 my %param = validate_with(params => \@_,
600 spec => {bug => {type => SCALAR,
603 # specific options here
604 tag => {type => SCALAR|ARRAYREF,
607 add => {type => BOOLEAN,
610 remove => {type => BOOLEAN,
613 warn_on_bad_tags => {type => BOOLEAN,
617 %append_action_options,
620 if ($param{add} and $param{remove}) {
621 croak "It's nonsensical to add and remove the same tags";
625 __begin_control(%param,
628 my ($debug,$transcript) =
629 @info{qw(debug transcript)};
630 my @data = @{$info{data}};
631 my @bugs = @{$info{bugs}};
632 my @tags = make_list($param{tag});
633 if (not @tags and ($param{remove} or $param{add})) {
634 if ($param{remove}) {
635 print {$transcript} "Requested to remove no tags; doing nothing.\n";
638 print {$transcript} "Requested to add no tags; doing nothing.\n";
640 __end_control(%info);
643 # first things first, make the versions fully qualified source
645 for my $data (@data) {
646 my $action = 'Did not alter tags';
648 my %tag_removed = ();
649 my %fixed_removed = ();
650 my @old_tags = split /\,?\s+/, $data->{keywords};
652 @tags{@old_tags} = (1) x @old_tags;
654 my $old_data = dclone($data);
655 if (not $param{add} and not $param{remove}) {
656 $tag_removed{$_} = 1 for @old_tags;
660 for my $tag (@tags) {
661 if (not $param{remove} and
662 not defined first {$_ eq $tag} @{$config{tags}}) {
663 push @bad_tags, $tag;
667 if (not exists $tags{$tag}) {
669 $tag_added{$tag} = 1;
672 elsif ($param{remove}) {
673 if (exists $tags{$tag}) {
675 $tag_removed{$tag} = 1;
679 if (exists $tag_removed{$tag}) {
680 delete $tag_removed{$tag};
683 $tag_added{$tag} = 1;
688 if (@bad_tags and $param{warn_on_bad_tags}) {
689 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
690 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
692 $data->{keywords} = join(' ',keys %tags);
695 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
696 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
697 $action = ucfirst(join ('; ',@changed)) if @changed;
699 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
700 unless __internal_request();
704 append_action_to_log(bug => $data->{bug_num},
707 old_data => $old_data,
709 __return_append_to_log_options(
714 if not exists $param{append_log} or $param{append_log};
715 writebug($data->{bug_num},$data);
716 print {$transcript} "$action\n";
718 __end_control(%info);
726 set_severity(bug => $ref,
727 transcript => $transcript,
728 ($dl > 0 ? (debug => $transcript):()),
729 requester => $header{from},
730 request_addr => $controlrequestaddr,
732 affected_packages => \%affected_packages,
733 recipients => \%recipients,
734 severity => 'normal',
739 print {$transcript} "Failed to set the severity of bug $ref: $@";
742 Sets the severity of a bug. If severity is not passed, is undefined,
743 or has zero length, sets the severity to the default severity.
748 my %param = validate_with(params => \@_,
749 spec => {bug => {type => SCALAR,
752 # specific options here
753 severity => {type => SCALAR|UNDEF,
754 default => $config{default_severity},
757 %append_action_options,
760 if (not defined $param{severity} or
761 not length $param{severity}
763 $param{severity} = $config{default_severity};
766 # check validity of new severity
767 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
768 die "Severity '$param{severity}' is not a valid severity level";
771 __begin_control(%param,
772 command => 'severity'
774 my ($debug,$transcript) =
775 @info{qw(debug transcript)};
776 my @data = @{$info{data}};
777 my @bugs = @{$info{bugs}};
780 for my $data (@data) {
781 if (not defined $data->{severity}) {
782 $data->{severity} = $param{severity};
783 $action = "Severity set to '$param{severity}'";
786 if ($data->{severity} eq '') {
787 $data->{severity} = $config{default_severity};
789 if ($data->{severity} eq $param{severity}) {
790 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
793 $action = "Severity set to '$param{severity}' from '$data->{severity}'";
794 $data->{severity} = $param{severity};
796 append_action_to_log(bug => $data->{bug_num},
798 __return_append_to_log_options(
803 if not exists $param{append_log} or $param{append_log};
804 writebug($data->{bug_num},$data);
805 print {$transcript} "$action\n";
807 __end_control(%info);
814 set_done(bug => $ref,
815 transcript => $transcript,
816 ($dl > 0 ? (debug => $transcript):()),
817 requester => $header{from},
818 request_addr => $controlrequestaddr,
820 affected_packages => \%affected_packages,
821 recipients => \%recipients,
826 print {$transcript} "Failed to set foo $ref bar: $@";
834 my %param = validate_with(params => \@_,
835 spec => {bug => {type => SCALAR,
838 reopen => {type => BOOLEAN,
841 submitter => {type => SCALAR,
844 clear_fixed => {type => BOOLEAN,
847 notify_submitter => {type => BOOLEAN,
850 original_report => {type => SCALARREF,
853 done => {type => SCALAR|UNDEF,
857 %append_action_options,
861 if (exists $param{submitter} and
862 not Mail::RFC822::Address::valid($param{submitter})) {
863 die "New submitter address '$param{submitter}' is not a valid e-mail address";
865 if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address
866 $param{done} = $param{requester};
868 if (exists $param{done} and
869 (not defined $param{done} or
870 not length $param{done})) {
876 __begin_control(%param,
877 command => $param{reopen}?'reopen':'done',
879 my ($debug,$transcript) =
880 @info{qw(debug transcript)};
881 my @data = @{$info{data}};
882 my @bugs = @{$info{bugs}};
885 if ($param{reopen}) {
886 # avoid warning multiple times if there are fixed versions
888 for my $data (@data) {
889 if (not exists $data->{done} or
890 not defined $data->{done} or
891 not length $data->{done}) {
892 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
893 __end_control(%info);
896 if (@{$data->{fixed_versions}} and $warn_fixed) {
897 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
898 print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n";
902 $action = "Bug reopened";
903 for my $data (@data) {
904 my $old_data = dclone($data);
906 append_action_to_log(bug => $data->{bug_num},
909 old_data => $old_data,
911 __return_append_to_log_options(
916 if not exists $param{append_log} or $param{append_log};
917 writebug($data->{bug_num},$data);
919 print {$transcript} "$action\n";
920 __end_control(%info);
921 if (exists $param{submitter}) {
922 set_submitter(bug => $param{bug},
923 submitter => $param{submitter},
925 keys %common_options,
926 keys %append_action_options)
929 # clear the fixed revisions
930 if ($param{clear_fixed}) {
931 set_fixed(fixed => [],
935 keys %common_options,
936 keys %append_action_options),
941 my %submitter_notified;
942 my $requester_notified = 0;
943 my $orig_report_set = 0;
944 for my $data (@data) {
945 if (exists $data->{done} and
946 defined $data->{done} and
947 length $data->{done}) {
948 print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
949 __end_control(%info);
953 for my $data (@data) {
954 my $old_data = dclone($data);
955 my $hash = get_hashname($data->{bug_num});
956 my $report_fh = IO::File->new("db-h/$hash/$data->{bug_num}.report",'r') or
957 die "Unable to open original report db-h/$hash/$data->{bug_num}.report for reading: $!";
961 $orig_report= <$report_fh>;
964 if (not $orig_report_set and defined $orig_report and
965 length $orig_report and
966 exists $param{original_report}){
967 ${$param{original_report}} = $orig_report;
968 $orig_report_set = 1;
971 $action = "Marked $config{bug} as done";
973 # set done to the requester
974 $data->{done} = exists $param{done}?$param{done}:$param{requester};
975 append_action_to_log(bug => $data->{bug_num},
978 old_data => $old_data,
980 __return_append_to_log_options(
985 if not exists $param{append_log} or $param{append_log};
986 writebug($data->{bug_num},$data);
987 print {$transcript} "$action\n";
988 # get the original report
989 if ($param{notify_submitter}) {
990 my $submitter_message;
991 if(not exists $submitter_notified{$data->{originator}}) {
993 create_mime_message([default_headers(queue_file => $param{request_nn},
995 msgid => $param{request_msgid},
996 msgtype => 'notifdone',
997 pr_msg => 'they-closed',
999 [To => $data->{submitter},
1000 Subject => "$config{ubug}#$data->{bug_num} ".
1001 "closed by $param{requester} ($param{request_subject})",
1005 __message_body_template('mail/process_your_bug_done',
1007 replyto => (exists $param{request_replyto} ?
1008 $param{request_replyto} :
1009 $param{requester} || 'Unknown'),
1010 markedby => $param{requester},
1011 subject => $param{request_subject},
1012 messageid => $param{request_msgid},
1015 [join('',make_list($param{message})),$orig_report]
1017 send_mail_message(message => $submitter_message,
1018 recipients => $old_data->{submitter},
1020 $submitter_notified{$data->{originator}} = $submitter_message;
1023 $submitter_message = $submitter_notified{$data->{originator}};
1025 append_action_to_log(bug => $data->{bug_num},
1026 action => "Notification sent",
1028 request_addr => $data->{originator},
1029 desc => "$config{bug} acknowledged by developer.",
1030 recips => [$data->{originator}],
1031 message => $submitter_message,
1036 __end_control(%info);
1037 if (exists $param{fixed}) {
1038 set_fixed(fixed => $param{fixed},
1042 keys %common_options,
1043 keys %append_action_options
1051 =head2 set_submitter
1054 set_submitter(bug => $ref,
1055 transcript => $transcript,
1056 ($dl > 0 ? (debug => $transcript):()),
1057 requester => $header{from},
1058 request_addr => $controlrequestaddr,
1060 affected_packages => \%affected_packages,
1061 recipients => \%recipients,
1062 submitter => $new_submitter,
1063 notify_submitter => 1,
1068 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1071 Sets the submitter of a bug. If notify_submitter is true (the
1072 default), notifies the old submitter of a bug on changes
1077 my %param = validate_with(params => \@_,
1078 spec => {bug => {type => SCALAR,
1081 # specific options here
1082 submitter => {type => SCALAR,
1084 notify_submitter => {type => BOOLEAN,
1088 %append_action_options,
1091 if (not Mail::RFC822::Address::valid($param{submitter})) {
1092 die "New submitter address $param{submitter} is not a valid e-mail address";
1095 __begin_control(%param,
1096 command => 'submitter'
1098 my ($debug,$transcript) =
1099 @info{qw(debug transcript)};
1100 my @data = @{$info{data}};
1101 my @bugs = @{$info{bugs}};
1103 # here we only concern ourselves with the first of the merged bugs
1104 for my $data ($data[0]) {
1105 my $notify_old_submitter = 0;
1106 my $old_data = dclone($data);
1107 print {$debug} "Going to change bug submitter\n";
1108 if (((not defined $param{submitter} or not length $param{submitter}) and
1109 (not defined $data->{originator} or not length $data->{originator})) or
1110 (defined $param{submitter} and defined $data->{originator} and
1111 $param{submitter} eq $data->{originator})) {
1112 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
1113 unless __internal_request();
1117 if (defined $data->{originator} and length($data->{originator})) {
1118 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
1119 $notify_old_submitter = 1;
1122 $action= "Set $config{bug} submitter to '$param{submitter}'.";
1124 $data->{originator} = $param{submitter};
1126 append_action_to_log(bug => $data->{bug_num},
1127 command => 'submitter',
1129 old_data => $old_data,
1131 __return_append_to_log_options(
1136 if not exists $param{append_log} or $param{append_log};
1137 writebug($data->{bug_num},$data);
1138 print {$transcript} "$action\n";
1139 # notify old submitter
1140 if ($notify_old_submitter and $param{notify_submitter}) {
1141 send_mail_message(message =>
1142 create_mime_message([default_headers(queue_file => $param{request_nn},
1144 msgid => $param{request_msgid},
1146 pr_msg => 'submitter-changed',
1148 [To => $old_data->{submitter},
1149 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
1153 __message_body_template('mail/submitter_changed',
1154 {old_data => $old_data,
1156 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
1160 recipients => $old_data->{submitter},
1164 __end_control(%info);
1169 =head2 set_forwarded
1172 set_forwarded(bug => $ref,
1173 transcript => $transcript,
1174 ($dl > 0 ? (debug => $transcript):()),
1175 requester => $header{from},
1176 request_addr => $controlrequestaddr,
1178 affected_packages => \%affected_packages,
1179 recipients => \%recipients,
1180 forwarded => $forward_to,
1185 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1188 Sets the location to which a bug is forwarded. Given an undef
1189 forwarded, unsets forwarded.
1195 my %param = validate_with(params => \@_,
1196 spec => {bug => {type => SCALAR,
1199 # specific options here
1200 forwarded => {type => SCALAR|UNDEF,
1203 %append_action_options,
1206 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1207 die "Non-printable characters are not allowed in the forwarded field";
1209 $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
1211 __begin_control(%param,
1212 command => 'forwarded'
1214 my ($debug,$transcript) =
1215 @info{qw(debug transcript)};
1216 my @data = @{$info{data}};
1217 my @bugs = @{$info{bugs}};
1219 for my $data (@data) {
1220 my $old_data = dclone($data);
1221 print {$debug} "Going to change bug forwarded\n";
1222 if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
1223 (not defined $param{forwarded} and
1224 defined $data->{forwarded} and not length $data->{forwarded})) {
1225 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1226 unless __internal_request();
1230 if (not defined $param{forwarded}) {
1231 $action= "Unset $config{bug} forwarded-to-address";
1233 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1234 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1237 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1239 $data->{forwarded} = $param{forwarded};
1241 append_action_to_log(bug => $data->{bug_num},
1242 command => 'forwarded',
1244 old_data => $old_data,
1246 __return_append_to_log_options(
1251 if not exists $param{append_log} or $param{append_log};
1252 writebug($data->{bug_num},$data);
1253 print {$transcript} "$action\n";
1255 __end_control(%info);
1264 set_title(bug => $ref,
1265 transcript => $transcript,
1266 ($dl > 0 ? (debug => $transcript):()),
1267 requester => $header{from},
1268 request_addr => $controlrequestaddr,
1270 affected_packages => \%affected_packages,
1271 recipients => \%recipients,
1272 title => $new_title,
1277 print {$transcript} "Failed to set the title of $ref: $@";
1280 Sets the title of a specific bug
1286 my %param = validate_with(params => \@_,
1287 spec => {bug => {type => SCALAR,
1290 # specific options here
1291 title => {type => SCALAR,
1294 %append_action_options,
1297 if ($param{title} =~ /[^[:print:]]/) {
1298 die "Non-printable characters are not allowed in bug titles";
1301 my %info = __begin_control(%param,
1304 my ($debug,$transcript) =
1305 @info{qw(debug transcript)};
1306 my @data = @{$info{data}};
1307 my @bugs = @{$info{bugs}};
1309 for my $data (@data) {
1310 my $old_data = dclone($data);
1311 print {$debug} "Going to change bug title\n";
1312 if (defined $data->{subject} and length($data->{subject}) and
1313 $data->{subject} eq $param{title}) {
1314 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1315 unless __internal_request();
1319 if (defined $data->{subject} and length($data->{subject})) {
1320 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1322 $action= "Set $config{bug} title to '$param{title}'.";
1324 $data->{subject} = $param{title};
1326 append_action_to_log(bug => $data->{bug_num},
1329 old_data => $old_data,
1331 __return_append_to_log_options(
1336 if not exists $param{append_log} or $param{append_log};
1337 writebug($data->{bug_num},$data);
1338 print {$transcript} "$action\n";
1340 __end_control(%info);
1347 set_package(bug => $ref,
1348 transcript => $transcript,
1349 ($dl > 0 ? (debug => $transcript):()),
1350 requester => $header{from},
1351 request_addr => $controlrequestaddr,
1353 affected_packages => \%affected_packages,
1354 recipients => \%recipients,
1355 package => $new_package,
1361 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1364 Indicates that a bug is in a particular package. If is_source is true,
1365 indicates that the package is a source package. [Internally, this
1366 causes src: to be prepended to the package name.]
1368 The default for is_source is 0. As a special case, if the package
1369 starts with 'src:', it is assumed to be a source package and is_source
1372 The package option must match the package_name_re regex.
1377 my %param = validate_with(params => \@_,
1378 spec => {bug => {type => SCALAR,
1381 # specific options here
1382 package => {type => SCALAR|ARRAYREF,
1384 is_source => {type => BOOLEAN,
1388 %append_action_options,
1391 my @new_packages = map {splitpackages($_)} make_list($param{package});
1392 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1393 croak "Invalid package name '".
1394 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1397 my %info = __begin_control(%param,
1398 command => 'package',
1400 my ($debug,$transcript) =
1401 @info{qw(debug transcript)};
1402 my @data = @{$info{data}};
1403 my @bugs = @{$info{bugs}};
1404 # clean up the new package
1408 ($temp =~ s/^src:// or
1409 $param{is_source}) ? 'src:'.$temp:$temp;
1413 my $package_reassigned = 0;
1414 for my $data (@data) {
1415 my $old_data = dclone($data);
1416 print {$debug} "Going to change assigned package\n";
1417 if (defined $data->{package} and length($data->{package}) and
1418 $data->{package} eq $new_package) {
1419 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1420 unless __internal_request();
1424 if (defined $data->{package} and length($data->{package})) {
1425 $package_reassigned = 1;
1426 $action= "$config{bug} reassigned from package '$data->{package}'".
1427 " to '$new_package'.";
1429 $action= "$config{bug} assigned to package '$new_package'.";
1431 $data->{package} = $new_package;
1433 append_action_to_log(bug => $data->{bug_num},
1434 command => 'package',
1436 old_data => $old_data,
1438 __return_append_to_log_options(
1443 if not exists $param{append_log} or $param{append_log};
1444 writebug($data->{bug_num},$data);
1445 print {$transcript} "$action\n";
1447 __end_control(%info);
1448 # Only clear the fixed/found versions if the package has been
1450 if ($package_reassigned) {
1451 my @params_for_found_fixed =
1452 map {exists $param{$_}?($_,$param{$_}):()}
1454 keys %common_options,
1455 keys %append_action_options,
1457 set_found(found => [],
1458 @params_for_found_fixed,
1460 set_fixed(fixed => [],
1461 @params_for_found_fixed,
1469 set_found(bug => $ref,
1470 transcript => $transcript,
1471 ($dl > 0 ? (debug => $transcript):()),
1472 requester => $header{from},
1473 request_addr => $controlrequestaddr,
1475 affected_packages => \%affected_packages,
1476 recipients => \%recipients,
1483 print {$transcript} "Failed to set found on $ref: $@";
1487 Sets, adds, or removes the specified found versions of a package
1489 If the version list is empty, and the bug is currently not "done",
1490 causes the done field to be cleared.
1492 If any of the versions added to found are greater than any version in
1493 which the bug is fixed (or when the bug is found and there are no
1494 fixed versions) the done field is cleared.
1499 my %param = validate_with(params => \@_,
1500 spec => {bug => {type => SCALAR,
1503 # specific options here
1504 found => {type => SCALAR|ARRAYREF,
1507 add => {type => BOOLEAN,
1510 remove => {type => BOOLEAN,
1514 %append_action_options,
1517 if ($param{add} and $param{remove}) {
1518 croak "It's nonsensical to add and remove the same versions";
1522 __begin_control(%param,
1525 my ($debug,$transcript) =
1526 @info{qw(debug transcript)};
1527 my @data = @{$info{data}};
1528 my @bugs = @{$info{bugs}};
1530 for my $version (make_list($param{found})) {
1531 next unless defined $version;
1532 $versions{$version} =
1533 [make_source_versions(package => [splitpackages($data[0]{package})],
1534 warnings => $transcript,
1537 versions => $version,
1540 # This is really ugly, but it's what we have to do
1541 if (not @{$versions{$version}}) {
1542 print {$transcript} "Unable to make a source version for version '$version'\n";
1545 if (not keys %versions and ($param{remove} or $param{add})) {
1546 if ($param{remove}) {
1547 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1550 print {$transcript} "Requested to add no versions; doing nothing.\n";
1552 __end_control(%info);
1555 # first things first, make the versions fully qualified source
1557 for my $data (@data) {
1558 # The 'done' field gets a bit weird with version tracking,
1559 # because a bug may be closed by multiple people in different
1560 # branches. Until we have something more flexible, we set it
1561 # every time a bug is fixed, and clear it when a bug is found
1562 # in a version greater than any version in which the bug is
1563 # fixed or when a bug is found and there is no fixed version
1564 my $action = 'Did not alter found versions';
1565 my %found_added = ();
1566 my %found_removed = ();
1567 my %fixed_removed = ();
1569 my $old_data = dclone($data);
1570 if (not $param{add} and not $param{remove}) {
1571 $found_removed{$_} = 1 for @{$data->{found_versions}};
1572 $data->{found_versions} = [];
1575 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1577 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1578 for my $version (keys %versions) {
1580 my @svers = @{$versions{$version}};
1584 for my $sver (@svers) {
1585 if (not exists $found_versions{$sver}) {
1586 $found_versions{$sver} = 1;
1587 $found_added{$sver} = 1;
1589 # if the found we are adding matches any fixed
1590 # versions, remove them
1591 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1592 delete $fixed_versions{$_} for @temp;
1593 $fixed_removed{$_} = 1 for @temp;
1596 # We only care about reopening the bug if the bug is
1598 if (defined $data->{done} and length $data->{done}) {
1599 my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
1601 # determine if we need to reopen
1602 my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
1603 keys %fixed_versions);
1604 if (not @fixed_order or
1605 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1611 elsif ($param{remove}) {
1612 # in the case of removal, we only concern ourself with
1613 # the version passed, not the source version it maps
1615 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1616 delete $found_versions{$_} for @temp;
1617 $found_removed{$_} = 1 for @temp;
1620 # set the keys to exactly these values
1621 my @svers = @{$versions{$version}};
1625 for my $sver (@svers) {
1626 if (not exists $found_versions{$sver}) {
1627 $found_versions{$sver} = 1;
1628 if (exists $found_removed{$sver}) {
1629 delete $found_removed{$sver};
1632 $found_added{$sver} = 1;
1639 $data->{found_versions} = [keys %found_versions];
1640 $data->{fixed_versions} = [keys %fixed_versions];
1643 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1644 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1645 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1646 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1647 $action = ucfirst(join ('; ',@changed)) if @changed;
1649 $action .= " and reopened"
1651 if (not $reopened and not @changed) {
1652 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1653 unless __internal_request();
1657 append_action_to_log(bug => $data->{bug_num},
1660 old_data => $old_data,
1662 __return_append_to_log_options(
1667 if not exists $param{append_log} or $param{append_log};
1668 writebug($data->{bug_num},$data);
1669 print {$transcript} "$action\n";
1671 __end_control(%info);
1677 set_fixed(bug => $ref,
1678 transcript => $transcript,
1679 ($dl > 0 ? (debug => $transcript):()),
1680 requester => $header{from},
1681 request_addr => $controlrequestaddr,
1683 affected_packages => \%affected_packages,
1684 recipients => \%recipients,
1692 print {$transcript} "Failed to set fixed on $ref: $@";
1696 Sets, adds, or removes the specified fixed versions of a package
1698 If the fixed versions are empty (or end up being empty after this
1699 call) or the greatest fixed version is less than the greatest found
1700 version and the reopen option is true, the bug is reopened.
1702 This function is also called by the reopen function, which causes all
1703 of the fixed versions to be cleared.
1708 my %param = validate_with(params => \@_,
1709 spec => {bug => {type => SCALAR,
1712 # specific options here
1713 fixed => {type => SCALAR|ARRAYREF,
1716 add => {type => BOOLEAN,
1719 remove => {type => BOOLEAN,
1722 reopen => {type => BOOLEAN,
1726 %append_action_options,
1729 if ($param{add} and $param{remove}) {
1730 croak "It's nonsensical to add and remove the same versions";
1733 __begin_control(%param,
1736 my ($debug,$transcript) =
1737 @info{qw(debug transcript)};
1738 my @data = @{$info{data}};
1739 my @bugs = @{$info{bugs}};
1741 for my $version (make_list($param{fixed})) {
1742 next unless defined $version;
1743 $versions{$version} =
1744 [make_source_versions(package => [splitpackages($data[0]{package})],
1745 warnings => $transcript,
1748 versions => $version,
1751 # This is really ugly, but it's what we have to do
1752 if (not @{$versions{$version}}) {
1753 print {$transcript} "Unable to make a source version for version '$version'\n";
1756 if (not keys %versions and ($param{remove} or $param{add})) {
1757 if ($param{remove}) {
1758 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1761 print {$transcript} "Requested to add no versions; doing nothing.\n";
1763 __end_control(%info);
1766 # first things first, make the versions fully qualified source
1768 for my $data (@data) {
1769 my $old_data = dclone($data);
1770 # The 'done' field gets a bit weird with version tracking,
1771 # because a bug may be closed by multiple people in different
1772 # branches. Until we have something more flexible, we set it
1773 # every time a bug is fixed, and clear it when a bug is found
1774 # in a version greater than any version in which the bug is
1775 # fixed or when a bug is found and there is no fixed version
1776 my $action = 'Did not alter fixed versions';
1777 my %found_added = ();
1778 my %found_removed = ();
1779 my %fixed_added = ();
1780 my %fixed_removed = ();
1782 if (not $param{add} and not $param{remove}) {
1783 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1784 $data->{fixed_versions} = [];
1787 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1789 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1790 for my $version (keys %versions) {
1792 my @svers = @{$versions{$version}};
1796 for my $sver (@svers) {
1797 if (not exists $fixed_versions{$sver}) {
1798 $fixed_versions{$sver} = 1;
1799 $fixed_added{$sver} = 1;
1803 elsif ($param{remove}) {
1804 # in the case of removal, we only concern ourself with
1805 # the version passed, not the source version it maps
1807 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1808 delete $fixed_versions{$_} for @temp;
1809 $fixed_removed{$_} = 1 for @temp;
1812 # set the keys to exactly these values
1813 my @svers = @{$versions{$version}};
1817 for my $sver (@svers) {
1818 if (not exists $fixed_versions{$sver}) {
1819 $fixed_versions{$sver} = 1;
1820 if (exists $fixed_removed{$sver}) {
1821 delete $fixed_removed{$sver};
1824 $fixed_added{$sver} = 1;
1831 $data->{found_versions} = [keys %found_versions];
1832 $data->{fixed_versions} = [keys %fixed_versions];
1834 # If we're supposed to consider reopening, reopen if the
1835 # fixed versions are empty or the greatest found version
1836 # is greater than the greatest fixed version
1837 if ($param{reopen} and defined $data->{done}
1838 and length $data->{done}) {
1839 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1840 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1841 # determine if we need to reopen
1842 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1843 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1844 if (not @fixed_order or
1845 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1852 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1853 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1854 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1855 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1856 $action = ucfirst(join ('; ',@changed)) if @changed;
1858 $action .= " and reopened"
1860 if (not $reopened and not @changed) {
1861 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1862 unless __internal_request();
1866 append_action_to_log(bug => $data->{bug_num},
1869 old_data => $old_data,
1871 __return_append_to_log_options(
1876 if not exists $param{append_log} or $param{append_log};
1877 writebug($data->{bug_num},$data);
1878 print {$transcript} "$action\n";
1880 __end_control(%info);
1887 set_merged(bug => $ref,
1888 transcript => $transcript,
1889 ($dl > 0 ? (debug => $transcript):()),
1890 requester => $header{from},
1891 request_addr => $controlrequestaddr,
1893 affected_packages => \%affected_packages,
1894 recipients => \%recipients,
1895 merge_with => 12345,
1898 allow_reassign => 1,
1899 reassign_same_source_only => 1,
1904 print {$transcript} "Failed to set merged on $ref: $@";
1908 Sets, adds, or removes the specified merged bugs of a bug
1910 By default, requires
1915 my %param = validate_with(params => \@_,
1916 spec => {bug => {type => SCALAR,
1919 # specific options here
1920 merge_with => {type => ARRAYREF|SCALAR,
1923 remove => {type => BOOLEAN,
1926 force => {type => BOOLEAN,
1929 masterbug => {type => BOOLEAN,
1932 allow_reassign => {type => BOOLEAN,
1935 reassign_different_sources => {type => BOOLEAN,
1939 %append_action_options,
1942 my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1944 @merging{@merging} = (1) x @merging;
1945 if (grep {$_ !~ /^\d+$/} @merging) {
1946 croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1948 $param{locks} = {} if not exists $param{locks};
1950 __begin_control(%param,
1953 my ($debug,$transcript) =
1954 @info{qw(debug transcript)};
1955 if (not @merging and exists $param{merge_with}) {
1956 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1957 __end_control(%info);
1960 my @data = @{$info{data}};
1961 my @bugs = @{$info{bugs}};
1964 for my $data (@data) {
1965 $data{$data->{bug_num}} = $data;
1966 my @merged_bugs = split / /, $data->{mergedwith};
1967 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1971 if (not exists $param{merge_with}) {
1972 my $ok_to_unmerge = 1;
1973 delete $merged_bugs{$param{bug}};
1974 if (not keys %merged_bugs) {
1975 print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1976 __end_control(%info);
1979 my $action = "Disconnected #$param{bug} from all other report(s).";
1980 for my $data (@data) {
1981 my $old_data = dclone($data);
1982 if ($data->{bug_num} == $param{bug}) {
1983 $data->{mergedwith} = '';
1986 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
1989 append_action_to_log(bug => $data->{bug_num},
1992 old_data => $old_data,
1994 __return_append_to_log_options(%param,
1998 if not exists $param{append_log} or $param{append_log};
1999 writebug($data->{bug_num},$data);
2001 print {$transcript} "$action\n";
2002 __end_control(%info);
2005 # lock and load all of the bugs we need
2006 my @bugs_to_load = keys %merging;
2009 my ($data,$n_locks) =
2010 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2012 locks => $param{locks},
2015 $new_locks += $n_locks;
2017 @data = values %data;
2018 if (not __check_limit(data => [@data],
2019 exists $param{limit}?(limit => $param{limit}):(),
2020 transcript => $transcript,
2022 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2024 for my $data (@data) {
2025 $data{$data->{bug_num}} = $data;
2026 $merged_bugs{$data->{bug_num}} = 1;
2027 my @merged_bugs = split / /, $data->{mergedwith};
2028 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2029 if (exists $param{affected_bugs}) {
2030 $param{affected_bugs}{$data->{bug_num}} = 1;
2033 __handle_affected_packages(%param,data => [@data]);
2034 my %bug_info_shown; # which bugs have had information shown
2035 $bug_info_shown{$param{bug}} = 1;
2036 add_recipients(data => [@data],
2037 recipients => $param{recipients},
2038 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2040 (__internal_request()?(transcript => $transcript):()),
2043 # Figure out what the ideal state is for the bug,
2044 my ($merge_status,$bugs_to_merge) =
2045 __calculate_merge_status(\@data,\%data,$param{bug});
2046 # find out if we actually have any bugs to merge
2047 if (not $bugs_to_merge) {
2048 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2049 for (1..$new_locks) {
2050 unfilelock($param{locks});
2053 __end_control(%info);
2056 # see what changes need to be made to merge the bugs
2057 # check to make sure that the set of changes we need to make is allowed
2058 my ($disallowed_changes,$changes) =
2059 __calculate_merge_changes(\@data,$merge_status,\%param);
2060 # at this point, stop if there are disallowed changes, otherwise
2061 # make the allowed changes, and then reread the bugs in question
2062 # to get the new data, then recaculate the merges; repeat
2063 # reloading and recalculating until we try too many times or there
2064 # are no changes to make.
2067 # we will allow at most 4 times through this; more than 1
2068 # shouldn't really happen.
2070 while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2071 if ($attempts > 1) {
2072 print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2074 if (@{$disallowed_changes}) {
2075 # figure out the problems
2076 print {$transcript} "Unable to merge bugs because:\n";
2077 for my $change (@{$disallowed_changes}) {
2078 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{orig_value}' not '$change->{value}'\n";
2080 if ($attempts > 0) {
2081 croak "Some bugs were altered while attempting to merge";
2084 croak "Did not alter merged bugs";
2087 my ($change_bug) = keys %{$changes};
2088 $bug_changed{$change_bug}++;
2089 print {$transcript} __bug_info($data{$change_bug}) if
2090 $param{show_bug_info} and not __internal_request(1);
2091 $bug_info_shown{$change_bug} = 1;
2092 __allow_relocking($param{locks},[keys %data]);
2093 for my $change (@{$changes->{$change_bug}}) {
2094 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2095 my %target_blockedby;
2096 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2097 my %unhandled_targets = %target_blockedby;
2098 my @blocks_to_remove;
2099 for my $key (split / /,$change->{orig_value}) {
2100 delete $unhandled_targets{$key};
2101 next if exists $target_blockedby{$key};
2102 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2103 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2106 keys %common_options,
2107 keys %append_action_options),
2110 for my $key (keys %unhandled_targets) {
2111 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2112 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2115 keys %common_options,
2116 keys %append_action_options),
2121 $change->{function}->(bug => $change->{bug},
2122 $change->{key}, $change->{func_value},
2123 exists $change->{options}?@{$change->{options}}:(),
2125 keys %common_options,
2126 keys %append_action_options),
2130 __disallow_relocking($param{locks});
2131 my ($data,$n_locks) =
2132 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2134 locks => $param{locks},
2138 $new_locks += $n_locks;
2141 @data = values %data;
2142 ($merge_status,$bugs_to_merge) =
2143 __calculate_merge_status(\@data,\%data,$param{bug});
2144 ($disallowed_changes,$changes) =
2145 __calculate_merge_changes(\@data,$merge_status,\%param);
2146 $attempts = max(values %bug_changed);
2148 if ($param{show_bug_info} and not __internal_request(1)) {
2149 for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2150 next if $bug_info_shown{$data->{bug_num}};
2151 print {$transcript} __bug_info($data);
2154 if (keys %{$changes} or @{$disallowed_changes}) {
2155 print {$transcript} "Unable to modify bugs so that they could be merged\n";
2156 for (1..$new_locks) {
2157 unfilelock($param{locks});
2160 __end_control(%info);
2164 # finally, we can merge the bugs
2165 my $action = "Merged ".join(' ',sort keys %merged_bugs);
2166 for my $data (@data) {
2167 my $old_data = dclone($data);
2168 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2170 append_action_to_log(bug => $data->{bug_num},
2173 old_data => $old_data,
2175 __return_append_to_log_options(%param,
2179 if not exists $param{append_log} or $param{append_log};
2180 writebug($data->{bug_num},$data);
2182 print {$transcript} "$action\n";
2183 # unlock the extra locks that we got earlier
2184 for (1..$new_locks) {
2185 unfilelock($param{locks});
2188 __end_control(%info);
2191 sub __allow_relocking{
2192 my ($locks,$bugs) = @_;
2194 for my $bug (@{$bugs}) {
2195 my @lockfiles = grep {m{/\Q$bug\E$}} keys %{$locks->{locks}};
2196 next unless @lockfiles;
2197 $locks->{relockable}{$lockfiles[0]} = 0;
2201 sub __disallow_relocking{
2203 delete $locks->{relockable};
2206 sub __lock_and_load_merged_bugs{
2208 validate_with(params => \@_,
2210 {bugs_to_load => {type => ARRAYREF,
2211 default => sub {[]},
2213 data => {type => HASHREF|ARRAYREF,
2215 locks => {type => HASHREF,
2216 default => sub {{};},
2218 reload_all => {type => BOOLEAN,
2221 debug => {type => HANDLE,
2227 if (ref($param{data}) eq 'ARRAY') {
2228 for my $data (@{$param{data}}) {
2229 $data{$data->{bug_num}} = dclone($data);
2233 %data = %{dclone($param{data})};
2235 my @bugs_to_load = @{$param{bugs_to_load}};
2236 if ($param{reload_all}) {
2237 push @bugs_to_load, keys %data;
2240 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2241 @bugs_to_load = keys %temp;
2242 my %loaded_this_time;
2244 while ($bug_to_load = shift @bugs_to_load) {
2245 if (not $param{reload_all}) {
2246 next if exists $data{$bug_to_load};
2249 next if $loaded_this_time{$bug_to_load};
2252 if ($param{reload_all}) {
2253 if (exists $data{$bug_to_load}) {
2258 read_bug(bug => $bug_to_load,
2260 locks => $param{locks},
2262 die "Unable to load bug $bug_to_load";
2263 print {$param{debug}} "read bug $bug_to_load\n";
2264 $data{$data->{bug_num}} = $data;
2265 $new_locks += $lock_bug;
2266 $loaded_this_time{$data->{bug_num}} = 1;
2268 grep {not exists $data{$_}}
2269 split / /,$data->{mergedwith};
2271 return (\%data,$new_locks);
2275 sub __calculate_merge_status{
2276 my ($data_a,$data_h,$master_bug,$merge) = @_;
2279 my $bugs_to_merge = 0;
2280 for my $data (@{$data_a}) {
2281 # check to see if this bug is unmerged in the set
2282 if (not length $data->{mergedwith} or
2283 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2284 $merged_bugs{$data->{bug_num}} = 1;
2287 # the master_bug is the bug that every other bug is made to
2288 # look like. However, if merge is set, tags, fixed and found
2290 if ($data->{bug_num} == $master_bug) {
2291 for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2292 $merge_status{$_} = $data->{$_}
2296 next unless $data->{bug_num} == $master_bug;
2298 $merge_status{tag} = {} if not exists $merge_status{tag};
2299 for my $tag (split /\s+/, $data->{keywords}) {
2300 $merge_status{tag}{$tag} = 1;
2302 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2303 for (qw(fixed found)) {
2304 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2307 return (\%merge_status,$bugs_to_merge);
2312 sub __calculate_merge_changes{
2313 my ($datas,$merge_status,$param) = @_;
2315 my @disallowed_changes;
2316 for my $data (@{$datas}) {
2317 # things that can be forced
2319 # * func is the function to set the new value
2321 # * key is the key of the function to set the value,
2323 # * modify_value is a function which is called to modify the new
2324 # value so that the function will accept it
2326 # * options is an ARRAYREF of options to pass to the function
2328 # * allowed is a BOOLEAN which controls whether this setting
2329 # is allowed to be different by default.
2330 my %force_functions =
2331 (forwarded => {func => \&set_forwarded,
2335 severity => {func => \&set_severity,
2339 blocks => {func => \&set_blocks,
2340 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2344 blockedby => {func => \&set_blocks,
2345 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2349 done => {func => \&set_done,
2353 owner => {func => \&owner,
2357 summary => {func => \&summary,
2361 affects => {func => \&affects,
2365 package => {func => \&set_package,
2369 keywords => {func => \&set_tag,
2371 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2374 fixed_versions => {func => \&set_fixed,
2378 found_versions => {func => \&set_found,
2383 for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2384 # if the ideal bug already has the field set properly, we
2386 if ($field eq 'keywords'){
2387 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2388 join(' ',sort keys %{$merge_status->{tag}});
2390 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2391 next if join(' ', sort @{$data->{$field}}) eq
2392 join(' ',sort keys %{$merge_status->{$field}});
2394 elsif ($merge_status->{$field} eq $data->{$field}) {
2399 bug => $data->{bug_num},
2400 orig_value => $data->{$field},
2402 (exists $force_functions{$field}{modify_value} ?
2403 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2404 $merge_status->{$field}),
2405 value => $merge_status->{$field},
2406 function => $force_functions{$field}{func},
2407 key => $force_functions{$field}{key},
2408 options => $force_functions{$field}{options},
2409 allowed => exists $force_functions{$field}{allowed} ? 0 : $force_functions{$field}{allowed},
2411 if ($param->{force}) {
2412 if ($field ne 'package') {
2413 push @{$changes{$data->{bug_num}}},$change;
2416 if ($param->{allow_reassign}) {
2417 if ($param->{reassign_different_sources}) {
2418 push @{$changes{$data->{bug_num}}},$change;
2421 # allow reassigning if binary_to_source returns at
2422 # least one of the same source packages
2423 my @merge_status_source =
2424 binary_to_source(package => $merge_status->{package},
2427 my @other_bug_source =
2428 binary_to_source(package => $data->{package},
2431 my %merge_status_sources;
2432 @merge_status_sources{@merge_status_source} =
2433 (1) x @merge_status_source;
2434 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2435 push @{$changes{$data->{bug_num}}},$change;
2440 push @disallowed_changes,$change;
2442 # blocks and blocked by are weird; we have to go through and
2443 # set blocks to the other half of the merged bugs
2445 return (\@disallowed_changes,\%changes);
2451 affects(bug => $ref,
2452 transcript => $transcript,
2453 ($dl > 0 ? (debug => $transcript):()),
2454 requester => $header{from},
2455 request_addr => $controlrequestaddr,
2457 affected_packages => \%affected_packages,
2458 recipients => \%recipients,
2466 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2469 This marks a bug as affecting packages which the bug is not actually
2470 in. This should only be used in cases where fixing the bug instantly
2471 resolves the problem in the other packages.
2473 By default, the packages are set to the list of packages passed.
2474 However, if you pass add => 1 or remove => 1, the list of packages
2475 passed are added or removed from the affects list, respectively.
2480 my %param = validate_with(params => \@_,
2481 spec => {bug => {type => SCALAR,
2484 # specific options here
2485 package => {type => SCALAR|ARRAYREF|UNDEF,
2488 add => {type => BOOLEAN,
2491 remove => {type => BOOLEAN,
2495 %append_action_options,
2498 if ($param{add} and $param{remove}) {
2499 croak "Asking to both add and remove affects is nonsensical";
2501 if (not defined $param{package}) {
2502 $param{package} = [];
2505 __begin_control(%param,
2506 command => 'affects'
2508 my ($debug,$transcript) =
2509 @info{qw(debug transcript)};
2510 my @data = @{$info{data}};
2511 my @bugs = @{$info{bugs}};
2513 for my $data (@data) {
2515 print {$debug} "Going to change affects\n";
2516 my @packages = splitpackages($data->{affects});
2518 @packages{@packages} = (1) x @packages;
2521 for my $package (make_list($param{package})) {
2522 next unless defined $package and length $package;
2523 if (not $packages{$package}) {
2524 $packages{$package} = 1;
2525 push @added,$package;
2529 $action = "Added indication that $data->{bug_num} affects ".
2530 english_join(\@added);
2533 elsif ($param{remove}) {
2535 for my $package (make_list($param{package})) {
2536 if ($packages{$package}) {
2537 next unless defined $package and length $package;
2538 delete $packages{$package};
2539 push @removed,$package;
2542 $action = "Removed indication that $data->{bug_num} affects " .
2543 english_join(\@removed);
2546 my %added_packages = ();
2547 my %removed_packages = %packages;
2549 for my $package (make_list($param{package})) {
2550 next unless defined $package and length $package;
2551 $packages{$package} = 1;
2552 delete $removed_packages{$package};
2553 $added_packages{$package} = 1;
2555 if (keys %removed_packages) {
2556 $action = "Removed indication that $data->{bug_num} affects ".
2557 english_join([keys %removed_packages]);
2558 $action .= "\n" if keys %added_packages;
2560 if (keys %added_packages) {
2561 $action .= "Added indication that $data->{bug_num} affects " .
2562 english_join([keys %added_packages]);
2565 if (not length $action) {
2566 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
2567 unless __internal_request();
2570 my $old_data = dclone($data);
2571 $data->{affects} = join(',',keys %packages);
2572 append_action_to_log(bug => $data->{bug_num},
2574 command => 'affects',
2576 old_data => $old_data,
2577 __return_append_to_log_options(
2582 if not exists $param{append_log} or $param{append_log};
2583 writebug($data->{bug_num},$data);
2584 print {$transcript} "$action\n";
2586 __end_control(%info);
2590 =head1 SUMMARY FUNCTIONS
2595 summary(bug => $ref,
2596 transcript => $transcript,
2597 ($dl > 0 ? (debug => $transcript):()),
2598 requester => $header{from},
2599 request_addr => $controlrequestaddr,
2601 affected_packages => \%affected_packages,
2602 recipients => \%recipients,
2608 print {$transcript} "Failed to mark $ref with summary foo: $@";
2611 Handles all setting of summary fields
2613 If summary is undef, unsets the summary
2615 If summary is 0, sets the summary to the first paragraph contained in
2618 If summary is a positive integer, sets the summary to the message specified.
2620 Otherwise, sets summary to the value passed.
2626 my %param = validate_with(params => \@_,
2627 spec => {bug => {type => SCALAR,
2630 # specific options here
2631 summary => {type => SCALAR|UNDEF,
2635 %append_action_options,
2638 # croak "summary must be numeric or undef" if
2639 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2641 __begin_control(%param,
2642 command => 'summary'
2644 my ($debug,$transcript) =
2645 @info{qw(debug transcript)};
2646 my @data = @{$info{data}};
2647 my @bugs = @{$info{bugs}};
2648 # figure out the log that we're going to use
2650 my $summary_msg = '';
2652 if (not defined $param{summary}) {
2654 print {$debug} "Removing summary fields\n";
2655 $action = 'Removed summary';
2657 elsif ($param{summary} =~ /^\d+$/) {
2659 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2660 if ($param{summary} == 0) {
2661 $log = $param{message};
2662 $summary_msg = @records + 1;
2665 if (($param{summary} - 1 ) > $#records) {
2666 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2668 my $record = $records[($param{summary} - 1 )];
2669 if ($record->{type} !~ /incoming-recv|recips/) {
2670 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2672 $summary_msg = $param{summary};
2673 $log = [$record->{text}];
2675 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2676 my $body = $p_o->{body};
2677 my $in_pseudoheaders = 0;
2679 # walk through body until we get non-blank lines
2680 for my $line (@{$body}) {
2681 if ($line =~ /^\s*$/) {
2682 if (length $paragraph) {
2683 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2689 $in_pseudoheaders = 0;
2692 # skip a paragraph if it looks like it's control or
2694 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2695 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2696 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2697 debug|(?:not|)forwarded|priority|
2698 (?:un|)block|limit|(?:un|)archive|
2699 reassign|retitle|affects|wrongpackage
2700 (?:un|force|)merge|user(?:category|tags?|)
2702 if (not length $paragraph) {
2703 print {$debug} "Found control/pseudo-headers and skiping them\n";
2704 $in_pseudoheaders = 1;
2708 next if $in_pseudoheaders;
2709 $paragraph .= $line ." \n";
2711 print {$debug} "Summary is going to be '$paragraph'\n";
2712 $summary = $paragraph;
2713 $summary =~ s/[\n\r]/ /g;
2714 if (not length $summary) {
2715 die "Unable to find summary message to use";
2717 # trim off a trailing spaces
2718 $summary =~ s/\ *$//;
2721 $summary = $param{summary};
2723 for my $data (@data) {
2724 print {$debug} "Going to change summary\n";
2725 if (((not defined $summary or not length $summary) and
2726 (not defined $data->{summary} or not length $data->{summary})) or
2727 $summary eq $data->{summary}) {
2728 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
2729 unless __internal_request();
2732 if (length $summary) {
2733 if (length $data->{summary}) {
2734 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2737 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2740 my $old_data = dclone($data);
2741 $data->{summary} = $summary;
2742 append_action_to_log(bug => $data->{bug_num},
2743 command => 'summary',
2744 old_data => $old_data,
2747 __return_append_to_log_options(
2752 if not exists $param{append_log} or $param{append_log};
2753 writebug($data->{bug_num},$data);
2754 print {$transcript} "$action\n";
2756 __end_control(%info);
2764 clone_bug(bug => $ref,
2765 transcript => $transcript,
2766 ($dl > 0 ? (debug => $transcript):()),
2767 requester => $header{from},
2768 request_addr => $controlrequestaddr,
2770 affected_packages => \%affected_packages,
2771 recipients => \%recipients,
2776 print {$transcript} "Failed to clone bug $ref bar: $@";
2779 Clones the given bug.
2781 We currently don't support cloning merged bugs, but this could be
2782 handled by internally unmerging, cloning, then remerging the bugs.
2787 my %param = validate_with(params => \@_,
2788 spec => {bug => {type => SCALAR,
2791 new_bugs => {type => ARRAYREF,
2793 new_clones => {type => HASHREF,
2797 %append_action_options,
2801 __begin_control(%param,
2804 my ($debug,$transcript) =
2805 @info{qw(debug transcript)};
2806 my @data = @{$info{data}};
2807 my @bugs = @{$info{bugs}};
2810 for my $data (@data) {
2811 if (length($data->{mergedwith})) {
2812 die "Bug is marked as being merged with others. Use an existing clone.\n";
2816 die "Not exactly one bug‽ This shouldn't happen.";
2818 my $data = $data[0];
2820 for my $newclone_id (@{$param{new_bugs}}) {
2821 my $new_bug_num = new_bug(copy => $data->{bug_num});
2822 $param{new_clones}{$newclone_id} = $new_bug_num;
2823 $clones{$newclone_id} = $new_bug_num;
2825 my @new_bugs = sort values %clones;
2827 for my $new_bug (@new_bugs) {
2828 # no collapsed ids or the higher collapsed id is not one less
2829 # than the next highest new bug
2830 if (not @collapsed_ids or
2831 $collapsed_ids[-1][1]+1 != $new_bug) {
2832 push @collapsed_ids,[$new_bug,$new_bug];
2835 $collapsed_ids[-1][1] = $new_bug;
2839 for my $ci (@collapsed_ids) {
2840 if ($ci->[0] == $ci->[1]) {
2841 push @collapsed,$ci->[0];
2844 push @collapsed,$ci->[0].'-'.$ci->[1]
2847 my $collapsed_str = english_join(\@collapsed);
2848 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2849 for my $new_bug (@new_bugs) {
2850 append_action_to_log(bug => $new_bug,
2852 __return_append_to_log_options(
2857 if not exists $param{append_log} or $param{append_log};
2859 append_action_to_log(bug => $data->{bug_num},
2861 __return_append_to_log_options(
2866 if not exists $param{append_log} or $param{append_log};
2867 writebug($data->{bug_num},$data);
2868 print {$transcript} "$action\n";
2869 __end_control(%info);
2870 # bugs that this bug is blocking are also blocked by the new clone(s)
2871 for my $bug (split ' ', $data->{blocks}) {
2872 for my $new_bug (@new_bugs) {
2873 set_blocks(bug => $new_bug,
2876 keys %common_options,
2877 keys %append_action_options),
2881 # bugs that this bug is blocked by are also blocking the new clone(s)
2882 for my $bug (split ' ', $data->{blockedby}) {
2883 for my $new_bug (@new_bugs) {
2884 set_blocks(bug => $bug,
2887 keys %common_options,
2888 keys %append_action_options),
2896 =head1 OWNER FUNCTIONS
2902 transcript => $transcript,
2903 ($dl > 0 ? (debug => $transcript):()),
2904 requester => $header{from},
2905 request_addr => $controlrequestaddr,
2907 recipients => \%recipients,
2913 print {$transcript} "Failed to mark $ref as having an owner: $@";
2916 Handles all setting of the owner field; given an owner of undef or of
2917 no length, indicates that a bug is not owned by anyone.
2922 my %param = validate_with(params => \@_,
2923 spec => {bug => {type => SCALAR,
2926 owner => {type => SCALAR|UNDEF,
2929 %append_action_options,
2933 __begin_control(%param,
2936 my ($debug,$transcript) =
2937 @info{qw(debug transcript)};
2938 my @data = @{$info{data}};
2939 my @bugs = @{$info{bugs}};
2941 for my $data (@data) {
2942 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2943 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2944 if (not defined $param{owner} or not length $param{owner}) {
2945 if (not defined $data->{owner} or not length $data->{owner}) {
2946 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2947 unless __internal_request();
2951 $action = "Removed annotation that $config{bug} was owned by " .
2955 if ($data->{owner} eq $param{owner}) {
2956 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2959 if (length $data->{owner}) {
2960 $action = "Owner changed from $data->{owner} to $param{owner}.";
2963 $action = "Owner recorded as $param{owner}."
2966 my $old_data = dclone($data);
2967 $data->{owner} = $param{owner};
2968 append_action_to_log(bug => $data->{bug_num},
2971 old_data => $old_data,
2973 __return_append_to_log_options(
2978 if not exists $param{append_log} or $param{append_log};
2979 writebug($data->{bug_num},$data);
2980 print {$transcript} "$action\n";
2982 __end_control(%info);
2986 =head1 ARCHIVE FUNCTIONS
2993 bug_archive(bug => $bug_num,
2995 transcript => \$transcript,
3000 transcript("Unable to archive $bug_num\n");
3003 transcript($transcript);
3006 This routine archives a bug
3010 =item bug -- bug number
3012 =item check_archiveable -- check wether a bug is archiveable before
3013 archiving; defaults to 1
3015 =item archive_unarchived -- whether to archive bugs which have not
3016 previously been archived; defaults to 1. [Set to 0 when used from
3019 =item ignore_time -- whether to ignore time constraints when archiving
3020 a bug; defaults to 0.
3027 my %param = validate_with(params => \@_,
3028 spec => {bug => {type => SCALAR,
3031 check_archiveable => {type => BOOLEAN,
3034 archive_unarchived => {type => BOOLEAN,
3037 ignore_time => {type => BOOLEAN,
3041 %append_action_options,
3044 my %info = __begin_control(%param,
3045 command => 'archive',
3047 my ($debug,$transcript) = @info{qw(debug transcript)};
3048 my @data = @{$info{data}};
3049 my @bugs = @{$info{bugs}};
3050 my $action = "$config{bug} archived.";
3051 if ($param{check_archiveable} and
3052 not bug_archiveable(bug=>$param{bug},
3053 ignore_time => $param{ignore_time},
3055 print {$transcript} "Bug $param{bug} cannot be archived\n";
3056 die "Bug $param{bug} cannot be archived";
3058 print {$debug} "$param{bug} considering\n";
3059 if (not $param{archive_unarchived} and
3060 not exists $data[0]{unarchived}
3062 print {$transcript} "$param{bug} has not been archived previously\n";
3063 die "$param{bug} has not been archived previously";
3065 add_recipients(recipients => $param{recipients},
3068 transcript => $transcript,
3070 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3071 for my $bug (@bugs) {
3072 if ($param{check_archiveable}) {
3073 die "Bug $bug cannot be archived (but $param{bug} can?)"
3074 unless bug_archiveable(bug=>$bug,
3075 ignore_time => $param{ignore_time},
3079 # If we get here, we can archive/remove this bug
3080 print {$debug} "$param{bug} removing\n";
3081 for my $bug (@bugs) {
3082 #print "$param{bug} removing $bug\n" if $debug;
3083 my $dir = get_hashname($bug);
3084 # First indicate that this bug is being archived
3085 append_action_to_log(bug => $bug,
3087 command => 'archive',
3088 # we didn't actually change the data
3089 # when we archived, so we don't pass
3090 # a real new_data or old_data
3093 __return_append_to_log_options(
3098 if not exists $param{append_log} or $param{append_log};
3099 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3100 if ($config{save_old_bugs}) {
3101 mkpath("$config{spool_dir}/archive/$dir");
3102 foreach my $file (@files_to_remove) {
3103 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3104 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3105 # we need to bail out here if things have
3106 # gone horribly wrong to avoid removing a
3108 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3111 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3113 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3114 print {$debug} "deleted $bug (from $param{bug})\n";
3116 bughook_archive(@bugs);
3117 __end_control(%info);
3120 =head2 bug_unarchive
3124 bug_unarchive(bug => $bug_num,
3126 transcript => \$transcript,
3131 transcript("Unable to archive bug: $bug_num");
3133 transcript($transcript);
3135 This routine unarchives a bug
3140 my %param = validate_with(params => \@_,
3141 spec => {bug => {type => SCALAR,
3145 %append_action_options,
3149 my %info = __begin_control(%param,
3151 command=>'unarchive');
3152 my ($debug,$transcript) =
3153 @info{qw(debug transcript)};
3154 my @data = @{$info{data}};
3155 my @bugs = @{$info{bugs}};
3156 my $action = "$config{bug} unarchived.";
3157 my @files_to_remove;
3158 for my $bug (@bugs) {
3159 print {$debug} "$param{bug} removing $bug\n";
3160 my $dir = get_hashname($bug);
3161 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3162 mkpath("archive/$dir");
3163 foreach my $file (@files_to_copy) {
3164 # die'ing here sucks
3165 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3166 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3167 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3169 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3170 print {$transcript} "Unarchived $config{bug} $bug\n";
3172 unlink(@files_to_remove) or die "Unable to unlink bugs";
3173 # Indicate that this bug has been archived previously
3174 for my $bug (@bugs) {
3175 my $newdata = readbug($bug);
3176 my $old_data = dclone($newdata);
3177 if (not defined $newdata) {
3178 print {$transcript} "$config{bug} $bug disappeared!\n";
3179 die "Bug $bug disappeared!";
3181 $newdata->{unarchived} = time;
3182 append_action_to_log(bug => $bug,
3184 command => 'unarchive',
3185 new_data => $newdata,
3186 old_data => $old_data,
3187 __return_append_to_log_options(
3192 if not exists $param{append_log} or $param{append_log};
3193 writebug($bug,$newdata);
3195 __end_control(%info);
3198 =head2 append_action_to_log
3200 append_action_to_log
3202 This should probably be moved to Debbugs::Log; have to think that out
3207 sub append_action_to_log{
3208 my %param = validate_with(params => \@_,
3209 spec => {bug => {type => SCALAR,
3212 new_data => {type => HASHREF,
3215 old_data => {type => HASHREF,
3218 command => {type => SCALAR,
3221 action => {type => SCALAR,
3223 requester => {type => SCALAR,
3226 request_addr => {type => SCALAR,
3229 location => {type => SCALAR,
3232 message => {type => SCALAR|ARRAYREF,
3235 recips => {type => SCALAR|ARRAYREF,
3238 desc => {type => SCALAR,
3241 get_lock => {type => BOOLEAN,
3244 locks => {type => HASHREF,
3248 # append_action_options here
3249 # because some of these
3250 # options aren't actually
3251 # optional, even though the
3252 # original function doesn't
3256 # Fix this to use $param{location}
3257 my $log_location = buglog($param{bug});
3258 die "Unable to find .log for $param{bug}"
3259 if not defined $log_location;
3260 if ($param{get_lock}) {
3261 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3265 my $logfh = IO::File->new(">>$log_location") or
3266 die "Unable to open $log_location for appending: $!";
3267 # determine difference between old and new
3269 if (exists $param{old_data} and exists $param{new_data}) {
3270 my $old_data = dclone($param{old_data});
3271 my $new_data = dclone($param{new_data});
3272 for my $key (keys %{$old_data}) {
3273 if (not exists $Debbugs::Status::fields{$key}) {
3274 delete $old_data->{$key};
3277 next unless exists $new_data->{$key};
3278 next unless defined $new_data->{$key};
3279 if (not defined $old_data->{$key}) {
3280 delete $old_data->{$key};
3283 if (ref($new_data->{$key}) and
3284 ref($old_data->{$key}) and
3285 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3286 local $Storable::canonical = 1;
3287 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3288 delete $new_data->{$key};
3289 delete $old_data->{$key};
3292 elsif ($new_data->{$key} eq $old_data->{$key}) {
3293 delete $new_data->{$key};
3294 delete $old_data->{$key};
3297 for my $key (keys %{$new_data}) {
3298 if (not exists $Debbugs::Status::fields{$key}) {
3299 delete $new_data->{$key};
3302 next unless exists $old_data->{$key};
3303 next unless defined $old_data->{$key};
3304 if (not defined $new_data->{$key} or
3305 not exists $Debbugs::Status::fields{$key}) {
3306 delete $new_data->{$key};
3309 if (ref($new_data->{$key}) and
3310 ref($old_data->{$key}) and
3311 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3312 local $Storable::canonical = 1;
3313 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3314 delete $new_data->{$key};
3315 delete $old_data->{$key};
3318 elsif ($new_data->{$key} eq $old_data->{$key}) {
3319 delete $new_data->{$key};
3320 delete $old_data->{$key};
3323 $data_diff .= "<!-- new_data:\n";
3325 for my $key (keys %{$new_data}) {
3326 if (not exists $Debbugs::Status::fields{$key}) {
3327 warn "No such field $key";
3330 $nd{$key} = $new_data->{$key};
3331 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3333 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3334 $data_diff .= "-->\n";
3335 $data_diff .= "<!-- old_data:\n";
3337 for my $key (keys %{$old_data}) {
3338 if (not exists $Debbugs::Status::fields{$key}) {
3339 warn "No such field $key";
3342 $od{$key} = $old_data->{$key};
3343 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3345 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3346 $data_diff .= "-->\n";
3349 (exists $param{command} ?
3350 "<!-- command:".html_escape($param{command})." -->\n":""
3352 (length $param{requester} ?
3353 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3355 (length $param{request_addr} ?
3356 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3358 "<!-- time:".time()." -->\n",
3360 "<strong>".html_escape($param{action})."</strong>\n");
3361 if (length $param{requester}) {
3362 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3364 if (length $param{request_addr}) {
3365 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3367 if (length $param{desc}) {
3368 $msg .= ":<br>\n$param{desc}\n";
3373 push @records, {type => 'html',
3377 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3378 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3379 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3380 text => join('',make_list($param{message})),
3383 write_log_records(logfh=>$logfh,
3384 records => \@records,
3386 close $logfh or die "Unable to close $log_location: $!";
3387 if ($param{get_lock}) {
3388 unfilelock(exists $param{locks}?$param{locks}:());
3396 =head1 PRIVATE FUNCTIONS
3398 =head2 __handle_affected_packages
3400 __handle_affected_packages(affected_packages => {},
3408 sub __handle_affected_packages{
3409 my %param = validate_with(params => \@_,
3410 spec => {%common_options,
3411 data => {type => ARRAYREF|HASHREF
3416 for my $data (make_list($param{data})) {
3417 next unless exists $data->{package} and defined $data->{package};
3418 my @packages = split /\s*,\s*/,$data->{package};
3419 @{$param{affected_packages}}{@packages} = (1) x @packages;
3423 =head2 __handle_debug_transcript
3425 my ($debug,$transcript) = __handle_debug_transcript(%param);
3427 Returns a debug and transcript filehandle
3432 sub __handle_debug_transcript{
3433 my %param = validate_with(params => \@_,
3434 spec => {%common_options},
3437 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3438 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3439 return ($debug,$transcript);
3446 Produces a small bit of bug information to kick out to the transcript
3453 next unless defined $data and exists $data->{bug_num};
3454 $return .= "Bug #".($data->{bug_num}||'').
3455 ((defined $data->{done} and length $data->{done})?
3456 " {Done: $data->{done}}":''
3458 " [".($data->{package}||'(no package)'). "] ".
3459 ($data->{subject}||'(no subject)')."\n";
3465 =head2 __internal_request
3467 __internal_request()
3468 __internal_request($level)
3470 Returns true if the caller of the function calling __internal_request
3471 belongs to __PACKAGE__
3473 This allows us to be magical, and don't bother to print bug info if
3474 the second caller is from this package, amongst other things.
3476 An optional level is allowed, which increments the number of levels to
3477 check by the given value. [This is basically for use by internal
3478 functions like __begin_control which are always called by
3483 sub __internal_request{
3485 $l = 0 if not defined $l;
3486 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3492 sub __return_append_to_log_options{
3494 my $action = $param{action} if exists $param{action};
3495 if (not exists $param{requester}) {
3496 $param{requester} = $config{control_internal_requester};
3498 if (not exists $param{request_addr}) {
3499 $param{request_addr} = $config{control_internal_request_addr};
3501 if (not exists $param{message}) {
3502 my $date = rfc822_date();
3503 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3504 variables => {request_addr => $param{request_addr},
3505 requester => $param{requester},
3511 if (not defined $action) {
3512 carp "Undefined action!";
3513 $action = "unknown action";
3515 return (action => $action,
3516 hash_slice(%param,keys %append_action_options),
3520 =head2 __begin_control
3522 my %info = __begin_control(%param,
3524 command=>'unarchive');
3525 my ($debug,$transcript) = @info{qw(debug transcript)};
3526 my @data = @{$info{data}};
3527 my @bugs = @{$info{bugs}};
3530 Starts the process of modifying a bug; handles all of the generic
3531 things that almost every control request needs
3533 Returns a hash containing
3537 =item new_locks -- number of new locks taken out by this call
3539 =item debug -- the debug file handle
3541 =item transcript -- the transcript file handle
3543 =item data -- an arrayref containing the data of the bugs
3544 corresponding to this request
3546 =item bugs -- an arrayref containing the bug numbers of the bugs
3547 corresponding to this request
3555 sub __begin_control {
3556 my %param = validate_with(params => \@_,
3557 spec => {bug => {type => SCALAR,
3560 archived => {type => BOOLEAN,
3563 command => {type => SCALAR,
3571 my ($debug,$transcript) = __handle_debug_transcript(@_);
3572 print {$debug} "$param{bug} considering\n";
3573 $lockhash = $param{locks} if exists $param{locks};
3575 my $old_die = $SIG{__DIE__};
3576 $SIG{__DIE__} = *sig_die{CODE};
3578 ($new_locks, @data) =
3579 lock_read_all_merged_bugs(bug => $param{bug},
3580 $param{archived}?(location => 'archive'):(),
3581 exists $param{locks} ? (locks => $param{locks}):(),
3583 $locks += $new_locks;
3585 die "Unable to read any bugs successfully.";
3587 if (not $param{archived}) {
3588 for my $data (@data) {
3589 if ($data->{archived}) {
3590 die "Not altering archived bugs; see unarchive.";
3594 if (not __check_limit(data => \@data,
3595 exists $param{limit}?(limit => $param{limit}):(),
3596 transcript => $transcript,
3598 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3601 __handle_affected_packages(%param,data => \@data);
3602 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3603 print {$debug} "$param{bug} read $locks locks\n";
3604 if (not @data or not defined $data[0]) {
3605 print {$transcript} "No bug found for $param{bug}\n";
3606 die "No bug found for $param{bug}";
3609 add_recipients(data => \@data,
3610 recipients => $param{recipients},
3611 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3613 (__internal_request()?(transcript => $transcript):()),
3616 print {$debug} "$param{bug} read done\n";
3617 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3618 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3619 return (data => \@data,
3621 old_die => $old_die,
3622 new_locks => $new_locks,
3624 transcript => $transcript,
3626 exists $param{locks}?(locks => $param{locks}):(),
3630 =head2 __end_control
3632 __end_control(%info);
3634 Handles tearing down from a control request
3640 if (exists $info{new_locks} and $info{new_locks} > 0) {
3641 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3642 for (1..$info{new_locks}) {
3643 unfilelock(exists $info{locks}?$info{locks}:());
3647 $SIG{__DIE__} = $info{old_die};
3648 if (exists $info{param}{affected_bugs}) {
3649 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3651 add_recipients(recipients => $info{param}{recipients},
3652 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3653 data => $info{data},
3654 debug => $info{debug},
3655 transcript => $info{transcript},
3657 __handle_affected_packages(%{$info{param}},data=>$info{data});
3661 =head2 __check_limit
3663 __check_limit(data => \@data, limit => $param{limit});
3666 Checks to make sure that bugs match any limits; each entry of @data
3667 much satisfy the limit.
3669 Returns true if there are no entries in data, or there are no keys in
3670 limit; returns false (0) if there are any entries which do not match.
3672 The limit hashref elements can contain an arrayref of scalars to
3673 match; regexes are also acccepted. At least one of the entries in each
3674 element needs to match the corresponding field in all data for the
3681 my %param = validate_with(params => \@_,
3682 spec => {data => {type => ARRAYREF|SCALAR,
3684 limit => {type => HASHREF|UNDEF,
3686 transcript => {type => SCALARREF|HANDLE,
3691 my @data = make_list($param{data});
3693 not defined $param{limit} or
3694 not keys %{$param{limit}}) {
3697 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3698 my $going_to_fail = 0;
3699 for my $data (@data) {
3700 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3701 status => dclone($data),
3703 for my $field (keys %{$param{limit}}) {
3704 next unless exists $param{limit}{$field};
3706 my @data_fields = make_list($data->{$field});
3707 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3708 if (not ref $limit) {
3709 for my $data_field (@data_fields) {
3710 if ($data_field eq $limit) {
3716 elsif (ref($limit) eq 'Regexp') {
3717 for my $data_field (@data_fields) {
3718 if ($data_field =~ $limit) {
3725 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3730 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3731 "' does not match at least one of ".
3732 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3736 return $going_to_fail?0:1;
3744 We override die to specially handle unlocking files in the cases where
3745 we are called via eval. [If we're not called via eval, it doesn't
3751 if ($^S) { # in eval
3753 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3760 # =head2 __message_body_template
3762 # message_body_template('mail/ack',{ref=>'foo'});
3764 # Creates a message body using a template
3768 sub __message_body_template{
3769 my ($template,$extra_var) = @_;
3771 my $hole_var = {'&bugurl' =>
3773 'http://'.$config{cgi_domain}.'/'.
3774 Debbugs::CGI::bug_url($_[0]);
3778 my $body = fill_in_template(template => $template,
3779 variables => {config => \%config,
3782 hole_var => $hole_var,
3784 return fill_in_template(template => 'mail/message_body',
3785 variables => {config => \%config,
3789 hole_var => $hole_var,
3793 sub __all_undef_or_equal {
3795 return 1 if @values == 1 or @values == 0;
3796 my $not_def = grep {not defined $_} @values;
3797 if ($not_def == @values) {
3800 if ($not_def > 0 and $not_def != @values) {
3803 my $first_val = shift @values;
3804 for my $val (@values) {
3805 if ($first_val ne $val) {