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->{text_orig_value}' not '$change->{text_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},$merge_status);
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 my @locks = (@{$bugs},'merge');
2195 for my $lock (@locks) {
2196 my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}};
2197 next unless @lockfiles;
2198 $locks->{relockable}{$lockfiles[0]} = 0;
2202 sub __disallow_relocking{
2204 delete $locks->{relockable};
2207 sub __lock_and_load_merged_bugs{
2209 validate_with(params => \@_,
2211 {bugs_to_load => {type => ARRAYREF,
2212 default => sub {[]},
2214 data => {type => HASHREF|ARRAYREF,
2216 locks => {type => HASHREF,
2217 default => sub {{};},
2219 reload_all => {type => BOOLEAN,
2222 debug => {type => HANDLE,
2228 if (ref($param{data}) eq 'ARRAY') {
2229 for my $data (@{$param{data}}) {
2230 $data{$data->{bug_num}} = dclone($data);
2234 %data = %{dclone($param{data})};
2236 my @bugs_to_load = @{$param{bugs_to_load}};
2237 if ($param{reload_all}) {
2238 push @bugs_to_load, keys %data;
2241 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2242 @bugs_to_load = keys %temp;
2243 my %loaded_this_time;
2245 while ($bug_to_load = shift @bugs_to_load) {
2246 if (not $param{reload_all}) {
2247 next if exists $data{$bug_to_load};
2250 next if $loaded_this_time{$bug_to_load};
2253 if ($param{reload_all}) {
2254 if (exists $data{$bug_to_load}) {
2259 read_bug(bug => $bug_to_load,
2261 locks => $param{locks},
2263 die "Unable to load bug $bug_to_load";
2264 print {$param{debug}} "read bug $bug_to_load\n";
2265 $data{$data->{bug_num}} = $data;
2266 $new_locks += $lock_bug;
2267 $loaded_this_time{$data->{bug_num}} = 1;
2269 grep {not exists $data{$_}}
2270 split / /,$data->{mergedwith};
2272 return (\%data,$new_locks);
2276 sub __calculate_merge_status{
2277 my ($data_a,$data_h,$master_bug,$merge_status) = @_;
2278 my %merge_status = %{$merge_status // {}};
2280 my $bugs_to_merge = 0;
2281 for my $data (@{$data_a}) {
2282 # check to see if this bug is unmerged in the set
2283 if (not length $data->{mergedwith} or
2284 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2285 $merged_bugs{$data->{bug_num}} = 1;
2288 # the master_bug is the bug that every other bug is made to
2289 # look like. However, if merge is set, tags, fixed and found
2291 if ($data->{bug_num} == $master_bug) {
2292 for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2293 $merge_status{$_} = $data->{$_}
2296 if (defined $merge_status) {
2297 next unless $data->{bug_num} == $master_bug;
2299 $merge_status{tag} = {} if not exists $merge_status{tag};
2300 for my $tag (split /\s+/, $data->{keywords}) {
2301 $merge_status{tag}{$tag} = 1;
2303 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2304 for (qw(fixed found)) {
2305 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2308 return (\%merge_status,$bugs_to_merge);
2313 sub __calculate_merge_changes{
2314 my ($datas,$merge_status,$param) = @_;
2316 my @disallowed_changes;
2317 for my $data (@{$datas}) {
2318 # things that can be forced
2320 # * func is the function to set the new value
2322 # * key is the key of the function to set the value,
2324 # * modify_value is a function which is called to modify the new
2325 # value so that the function will accept it
2327 # * options is an ARRAYREF of options to pass to the function
2329 # * allowed is a BOOLEAN which controls whether this setting
2330 # is allowed to be different by default.
2331 my %force_functions =
2332 (forwarded => {func => \&set_forwarded,
2336 severity => {func => \&set_severity,
2340 blocks => {func => \&set_blocks,
2341 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2345 blockedby => {func => \&set_blocks,
2346 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2350 done => {func => \&set_done,
2354 owner => {func => \&owner,
2358 summary => {func => \&summary,
2362 affects => {func => \&affects,
2366 package => {func => \&set_package,
2370 keywords => {func => \&set_tag,
2372 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2375 fixed_versions => {func => \&set_fixed,
2377 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2380 found_versions => {func => \&set_found,
2382 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2386 for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2387 # if the ideal bug already has the field set properly, we
2389 if ($field eq 'keywords'){
2390 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2391 join(' ',sort keys %{$merge_status->{tag}});
2393 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2394 next if join(' ', sort @{$data->{$field}}) eq
2395 join(' ',sort keys %{$merge_status->{$field}});
2397 elsif ($merge_status->{$field} eq $data->{$field}) {
2402 bug => $data->{bug_num},
2403 orig_value => $data->{$field},
2405 (exists $force_functions{$field}{modify_value} ?
2406 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2407 $merge_status->{$field}),
2408 value => $merge_status->{$field},
2409 function => $force_functions{$field}{func},
2410 key => $force_functions{$field}{key},
2411 options => $force_functions{$field}{options},
2412 allowed => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0,
2414 $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
2415 $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
2416 if ($param->{force} or $change->{allowed}) {
2417 if ($field ne 'package' or $change->{allowed}) {
2418 push @{$changes{$data->{bug_num}}},$change;
2421 if ($param->{allow_reassign}) {
2422 if ($param->{reassign_different_sources}) {
2423 push @{$changes{$data->{bug_num}}},$change;
2426 # allow reassigning if binary_to_source returns at
2427 # least one of the same source packages
2428 my @merge_status_source =
2429 binary_to_source(package => $merge_status->{package},
2432 my @other_bug_source =
2433 binary_to_source(package => $data->{package},
2436 my %merge_status_sources;
2437 @merge_status_sources{@merge_status_source} =
2438 (1) x @merge_status_source;
2439 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2440 push @{$changes{$data->{bug_num}}},$change;
2445 push @disallowed_changes,$change;
2447 # blocks and blocked by are weird; we have to go through and
2448 # set blocks to the other half of the merged bugs
2450 return (\@disallowed_changes,\%changes);
2456 affects(bug => $ref,
2457 transcript => $transcript,
2458 ($dl > 0 ? (debug => $transcript):()),
2459 requester => $header{from},
2460 request_addr => $controlrequestaddr,
2462 affected_packages => \%affected_packages,
2463 recipients => \%recipients,
2471 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2474 This marks a bug as affecting packages which the bug is not actually
2475 in. This should only be used in cases where fixing the bug instantly
2476 resolves the problem in the other packages.
2478 By default, the packages are set to the list of packages passed.
2479 However, if you pass add => 1 or remove => 1, the list of packages
2480 passed are added or removed from the affects list, respectively.
2485 my %param = validate_with(params => \@_,
2486 spec => {bug => {type => SCALAR,
2489 # specific options here
2490 package => {type => SCALAR|ARRAYREF|UNDEF,
2493 add => {type => BOOLEAN,
2496 remove => {type => BOOLEAN,
2500 %append_action_options,
2503 if ($param{add} and $param{remove}) {
2504 croak "Asking to both add and remove affects is nonsensical";
2506 if (not defined $param{package}) {
2507 $param{package} = [];
2510 __begin_control(%param,
2511 command => 'affects'
2513 my ($debug,$transcript) =
2514 @info{qw(debug transcript)};
2515 my @data = @{$info{data}};
2516 my @bugs = @{$info{bugs}};
2518 for my $data (@data) {
2520 print {$debug} "Going to change affects\n";
2521 my @packages = splitpackages($data->{affects});
2523 @packages{@packages} = (1) x @packages;
2526 for my $package (make_list($param{package})) {
2527 next unless defined $package and length $package;
2528 if (not $packages{$package}) {
2529 $packages{$package} = 1;
2530 push @added,$package;
2534 $action = "Added indication that $data->{bug_num} affects ".
2535 english_join(\@added);
2538 elsif ($param{remove}) {
2540 for my $package (make_list($param{package})) {
2541 if ($packages{$package}) {
2542 next unless defined $package and length $package;
2543 delete $packages{$package};
2544 push @removed,$package;
2547 $action = "Removed indication that $data->{bug_num} affects " .
2548 english_join(\@removed);
2551 my %added_packages = ();
2552 my %removed_packages = %packages;
2554 for my $package (make_list($param{package})) {
2555 next unless defined $package and length $package;
2556 $packages{$package} = 1;
2557 delete $removed_packages{$package};
2558 $added_packages{$package} = 1;
2560 if (keys %removed_packages) {
2561 $action = "Removed indication that $data->{bug_num} affects ".
2562 english_join([keys %removed_packages]);
2563 $action .= "\n" if keys %added_packages;
2565 if (keys %added_packages) {
2566 $action .= "Added indication that $data->{bug_num} affects " .
2567 english_join([keys %added_packages]);
2570 if (not length $action) {
2571 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
2572 unless __internal_request();
2575 my $old_data = dclone($data);
2576 $data->{affects} = join(',',keys %packages);
2577 append_action_to_log(bug => $data->{bug_num},
2579 command => 'affects',
2581 old_data => $old_data,
2582 __return_append_to_log_options(
2587 if not exists $param{append_log} or $param{append_log};
2588 writebug($data->{bug_num},$data);
2589 print {$transcript} "$action\n";
2591 __end_control(%info);
2595 =head1 SUMMARY FUNCTIONS
2600 summary(bug => $ref,
2601 transcript => $transcript,
2602 ($dl > 0 ? (debug => $transcript):()),
2603 requester => $header{from},
2604 request_addr => $controlrequestaddr,
2606 affected_packages => \%affected_packages,
2607 recipients => \%recipients,
2613 print {$transcript} "Failed to mark $ref with summary foo: $@";
2616 Handles all setting of summary fields
2618 If summary is undef, unsets the summary
2620 If summary is 0, sets the summary to the first paragraph contained in
2623 If summary is a positive integer, sets the summary to the message specified.
2625 Otherwise, sets summary to the value passed.
2631 my %param = validate_with(params => \@_,
2632 spec => {bug => {type => SCALAR,
2635 # specific options here
2636 summary => {type => SCALAR|UNDEF,
2640 %append_action_options,
2643 # croak "summary must be numeric or undef" if
2644 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2646 __begin_control(%param,
2647 command => 'summary'
2649 my ($debug,$transcript) =
2650 @info{qw(debug transcript)};
2651 my @data = @{$info{data}};
2652 my @bugs = @{$info{bugs}};
2653 # figure out the log that we're going to use
2655 my $summary_msg = '';
2657 if (not defined $param{summary}) {
2659 print {$debug} "Removing summary fields\n";
2660 $action = 'Removed summary';
2662 elsif ($param{summary} =~ /^\d+$/) {
2664 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2665 if ($param{summary} == 0) {
2666 $log = $param{message};
2667 $summary_msg = @records + 1;
2670 if (($param{summary} - 1 ) > $#records) {
2671 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2673 my $record = $records[($param{summary} - 1 )];
2674 if ($record->{type} !~ /incoming-recv|recips/) {
2675 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2677 $summary_msg = $param{summary};
2678 $log = [$record->{text}];
2680 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2681 my $body = $p_o->{body};
2682 my $in_pseudoheaders = 0;
2684 # walk through body until we get non-blank lines
2685 for my $line (@{$body}) {
2686 if ($line =~ /^\s*$/) {
2687 if (length $paragraph) {
2688 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2694 $in_pseudoheaders = 0;
2697 # skip a paragraph if it looks like it's control or
2699 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2700 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2701 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2702 debug|(?:not|)forwarded|priority|
2703 (?:un|)block|limit|(?:un|)archive|
2704 reassign|retitle|affects|wrongpackage
2705 (?:un|force|)merge|user(?:category|tags?|)
2707 if (not length $paragraph) {
2708 print {$debug} "Found control/pseudo-headers and skiping them\n";
2709 $in_pseudoheaders = 1;
2713 next if $in_pseudoheaders;
2714 $paragraph .= $line ." \n";
2716 print {$debug} "Summary is going to be '$paragraph'\n";
2717 $summary = $paragraph;
2718 $summary =~ s/[\n\r]/ /g;
2719 if (not length $summary) {
2720 die "Unable to find summary message to use";
2722 # trim off a trailing spaces
2723 $summary =~ s/\ *$//;
2726 $summary = $param{summary};
2728 for my $data (@data) {
2729 print {$debug} "Going to change summary\n";
2730 if (((not defined $summary or not length $summary) and
2731 (not defined $data->{summary} or not length $data->{summary})) or
2732 $summary eq $data->{summary}) {
2733 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
2734 unless __internal_request();
2737 if (length $summary) {
2738 if (length $data->{summary}) {
2739 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2742 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2745 my $old_data = dclone($data);
2746 $data->{summary} = $summary;
2747 append_action_to_log(bug => $data->{bug_num},
2748 command => 'summary',
2749 old_data => $old_data,
2752 __return_append_to_log_options(
2757 if not exists $param{append_log} or $param{append_log};
2758 writebug($data->{bug_num},$data);
2759 print {$transcript} "$action\n";
2761 __end_control(%info);
2769 clone_bug(bug => $ref,
2770 transcript => $transcript,
2771 ($dl > 0 ? (debug => $transcript):()),
2772 requester => $header{from},
2773 request_addr => $controlrequestaddr,
2775 affected_packages => \%affected_packages,
2776 recipients => \%recipients,
2781 print {$transcript} "Failed to clone bug $ref bar: $@";
2784 Clones the given bug.
2786 We currently don't support cloning merged bugs, but this could be
2787 handled by internally unmerging, cloning, then remerging the bugs.
2792 my %param = validate_with(params => \@_,
2793 spec => {bug => {type => SCALAR,
2796 new_bugs => {type => ARRAYREF,
2798 new_clones => {type => HASHREF,
2802 %append_action_options,
2806 __begin_control(%param,
2809 my ($debug,$transcript) =
2810 @info{qw(debug transcript)};
2811 my @data = @{$info{data}};
2812 my @bugs = @{$info{bugs}};
2815 for my $data (@data) {
2816 if (length($data->{mergedwith})) {
2817 die "Bug is marked as being merged with others. Use an existing clone.\n";
2821 die "Not exactly one bug‽ This shouldn't happen.";
2823 my $data = $data[0];
2825 for my $newclone_id (@{$param{new_bugs}}) {
2826 my $new_bug_num = new_bug(copy => $data->{bug_num});
2827 $param{new_clones}{$newclone_id} = $new_bug_num;
2828 $clones{$newclone_id} = $new_bug_num;
2830 my @new_bugs = sort values %clones;
2832 for my $new_bug (@new_bugs) {
2833 # no collapsed ids or the higher collapsed id is not one less
2834 # than the next highest new bug
2835 if (not @collapsed_ids or
2836 $collapsed_ids[-1][1]+1 != $new_bug) {
2837 push @collapsed_ids,[$new_bug,$new_bug];
2840 $collapsed_ids[-1][1] = $new_bug;
2844 for my $ci (@collapsed_ids) {
2845 if ($ci->[0] == $ci->[1]) {
2846 push @collapsed,$ci->[0];
2849 push @collapsed,$ci->[0].'-'.$ci->[1]
2852 my $collapsed_str = english_join(\@collapsed);
2853 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2854 for my $new_bug (@new_bugs) {
2855 append_action_to_log(bug => $new_bug,
2857 __return_append_to_log_options(
2862 if not exists $param{append_log} or $param{append_log};
2864 append_action_to_log(bug => $data->{bug_num},
2866 __return_append_to_log_options(
2871 if not exists $param{append_log} or $param{append_log};
2872 writebug($data->{bug_num},$data);
2873 print {$transcript} "$action\n";
2874 __end_control(%info);
2875 # bugs that this bug is blocking are also blocked by the new clone(s)
2876 for my $bug (split ' ', $data->{blocks}) {
2877 for my $new_bug (@new_bugs) {
2878 set_blocks(bug => $new_bug,
2881 keys %common_options,
2882 keys %append_action_options),
2886 # bugs that this bug is blocked by are also blocking the new clone(s)
2887 for my $bug (split ' ', $data->{blockedby}) {
2888 for my $new_bug (@new_bugs) {
2889 set_blocks(bug => $bug,
2892 keys %common_options,
2893 keys %append_action_options),
2901 =head1 OWNER FUNCTIONS
2907 transcript => $transcript,
2908 ($dl > 0 ? (debug => $transcript):()),
2909 requester => $header{from},
2910 request_addr => $controlrequestaddr,
2912 recipients => \%recipients,
2918 print {$transcript} "Failed to mark $ref as having an owner: $@";
2921 Handles all setting of the owner field; given an owner of undef or of
2922 no length, indicates that a bug is not owned by anyone.
2927 my %param = validate_with(params => \@_,
2928 spec => {bug => {type => SCALAR,
2931 owner => {type => SCALAR|UNDEF,
2934 %append_action_options,
2938 __begin_control(%param,
2941 my ($debug,$transcript) =
2942 @info{qw(debug transcript)};
2943 my @data = @{$info{data}};
2944 my @bugs = @{$info{bugs}};
2946 for my $data (@data) {
2947 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2948 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2949 if (not defined $param{owner} or not length $param{owner}) {
2950 if (not defined $data->{owner} or not length $data->{owner}) {
2951 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2952 unless __internal_request();
2956 $action = "Removed annotation that $config{bug} was owned by " .
2960 if ($data->{owner} eq $param{owner}) {
2961 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2964 if (length $data->{owner}) {
2965 $action = "Owner changed from $data->{owner} to $param{owner}.";
2968 $action = "Owner recorded as $param{owner}."
2971 my $old_data = dclone($data);
2972 $data->{owner} = $param{owner};
2973 append_action_to_log(bug => $data->{bug_num},
2976 old_data => $old_data,
2978 __return_append_to_log_options(
2983 if not exists $param{append_log} or $param{append_log};
2984 writebug($data->{bug_num},$data);
2985 print {$transcript} "$action\n";
2987 __end_control(%info);
2991 =head1 ARCHIVE FUNCTIONS
2998 bug_archive(bug => $bug_num,
3000 transcript => \$transcript,
3005 transcript("Unable to archive $bug_num\n");
3008 transcript($transcript);
3011 This routine archives a bug
3015 =item bug -- bug number
3017 =item check_archiveable -- check wether a bug is archiveable before
3018 archiving; defaults to 1
3020 =item archive_unarchived -- whether to archive bugs which have not
3021 previously been archived; defaults to 1. [Set to 0 when used from
3024 =item ignore_time -- whether to ignore time constraints when archiving
3025 a bug; defaults to 0.
3032 my %param = validate_with(params => \@_,
3033 spec => {bug => {type => SCALAR,
3036 check_archiveable => {type => BOOLEAN,
3039 archive_unarchived => {type => BOOLEAN,
3042 ignore_time => {type => BOOLEAN,
3046 %append_action_options,
3049 my %info = __begin_control(%param,
3050 command => 'archive',
3052 my ($debug,$transcript) = @info{qw(debug transcript)};
3053 my @data = @{$info{data}};
3054 my @bugs = @{$info{bugs}};
3055 my $action = "$config{bug} archived.";
3056 if ($param{check_archiveable} and
3057 not bug_archiveable(bug=>$param{bug},
3058 ignore_time => $param{ignore_time},
3060 print {$transcript} "Bug $param{bug} cannot be archived\n";
3061 die "Bug $param{bug} cannot be archived";
3063 print {$debug} "$param{bug} considering\n";
3064 if (not $param{archive_unarchived} and
3065 not exists $data[0]{unarchived}
3067 print {$transcript} "$param{bug} has not been archived previously\n";
3068 die "$param{bug} has not been archived previously";
3070 add_recipients(recipients => $param{recipients},
3073 transcript => $transcript,
3075 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3076 for my $bug (@bugs) {
3077 if ($param{check_archiveable}) {
3078 die "Bug $bug cannot be archived (but $param{bug} can?)"
3079 unless bug_archiveable(bug=>$bug,
3080 ignore_time => $param{ignore_time},
3084 # If we get here, we can archive/remove this bug
3085 print {$debug} "$param{bug} removing\n";
3086 for my $bug (@bugs) {
3087 #print "$param{bug} removing $bug\n" if $debug;
3088 my $dir = get_hashname($bug);
3089 # First indicate that this bug is being archived
3090 append_action_to_log(bug => $bug,
3092 command => 'archive',
3093 # we didn't actually change the data
3094 # when we archived, so we don't pass
3095 # a real new_data or old_data
3098 __return_append_to_log_options(
3103 if not exists $param{append_log} or $param{append_log};
3104 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3105 if ($config{save_old_bugs}) {
3106 mkpath("$config{spool_dir}/archive/$dir");
3107 foreach my $file (@files_to_remove) {
3108 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3109 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3110 # we need to bail out here if things have
3111 # gone horribly wrong to avoid removing a
3113 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3116 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3118 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3119 print {$debug} "deleted $bug (from $param{bug})\n";
3121 bughook_archive(@bugs);
3122 __end_control(%info);
3125 =head2 bug_unarchive
3129 bug_unarchive(bug => $bug_num,
3131 transcript => \$transcript,
3136 transcript("Unable to archive bug: $bug_num");
3138 transcript($transcript);
3140 This routine unarchives a bug
3145 my %param = validate_with(params => \@_,
3146 spec => {bug => {type => SCALAR,
3150 %append_action_options,
3154 my %info = __begin_control(%param,
3156 command=>'unarchive');
3157 my ($debug,$transcript) =
3158 @info{qw(debug transcript)};
3159 my @data = @{$info{data}};
3160 my @bugs = @{$info{bugs}};
3161 my $action = "$config{bug} unarchived.";
3162 my @files_to_remove;
3163 for my $bug (@bugs) {
3164 print {$debug} "$param{bug} removing $bug\n";
3165 my $dir = get_hashname($bug);
3166 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3167 mkpath("archive/$dir");
3168 foreach my $file (@files_to_copy) {
3169 # die'ing here sucks
3170 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3171 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3172 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3174 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3175 print {$transcript} "Unarchived $config{bug} $bug\n";
3177 unlink(@files_to_remove) or die "Unable to unlink bugs";
3178 # Indicate that this bug has been archived previously
3179 for my $bug (@bugs) {
3180 my $newdata = readbug($bug);
3181 my $old_data = dclone($newdata);
3182 if (not defined $newdata) {
3183 print {$transcript} "$config{bug} $bug disappeared!\n";
3184 die "Bug $bug disappeared!";
3186 $newdata->{unarchived} = time;
3187 append_action_to_log(bug => $bug,
3189 command => 'unarchive',
3190 new_data => $newdata,
3191 old_data => $old_data,
3192 __return_append_to_log_options(
3197 if not exists $param{append_log} or $param{append_log};
3198 writebug($bug,$newdata);
3200 __end_control(%info);
3203 =head2 append_action_to_log
3205 append_action_to_log
3207 This should probably be moved to Debbugs::Log; have to think that out
3212 sub append_action_to_log{
3213 my %param = validate_with(params => \@_,
3214 spec => {bug => {type => SCALAR,
3217 new_data => {type => HASHREF,
3220 old_data => {type => HASHREF,
3223 command => {type => SCALAR,
3226 action => {type => SCALAR,
3228 requester => {type => SCALAR,
3231 request_addr => {type => SCALAR,
3234 location => {type => SCALAR,
3237 message => {type => SCALAR|ARRAYREF,
3240 recips => {type => SCALAR|ARRAYREF,
3243 desc => {type => SCALAR,
3246 get_lock => {type => BOOLEAN,
3249 locks => {type => HASHREF,
3253 # append_action_options here
3254 # because some of these
3255 # options aren't actually
3256 # optional, even though the
3257 # original function doesn't
3261 # Fix this to use $param{location}
3262 my $log_location = buglog($param{bug});
3263 die "Unable to find .log for $param{bug}"
3264 if not defined $log_location;
3265 if ($param{get_lock}) {
3266 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3270 my $logfh = IO::File->new(">>$log_location") or
3271 die "Unable to open $log_location for appending: $!";
3272 # determine difference between old and new
3274 if (exists $param{old_data} and exists $param{new_data}) {
3275 my $old_data = dclone($param{old_data});
3276 my $new_data = dclone($param{new_data});
3277 for my $key (keys %{$old_data}) {
3278 if (not exists $Debbugs::Status::fields{$key}) {
3279 delete $old_data->{$key};
3282 next unless exists $new_data->{$key};
3283 next unless defined $new_data->{$key};
3284 if (not defined $old_data->{$key}) {
3285 delete $old_data->{$key};
3288 if (ref($new_data->{$key}) and
3289 ref($old_data->{$key}) and
3290 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3291 local $Storable::canonical = 1;
3292 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3293 delete $new_data->{$key};
3294 delete $old_data->{$key};
3297 elsif ($new_data->{$key} eq $old_data->{$key}) {
3298 delete $new_data->{$key};
3299 delete $old_data->{$key};
3302 for my $key (keys %{$new_data}) {
3303 if (not exists $Debbugs::Status::fields{$key}) {
3304 delete $new_data->{$key};
3307 next unless exists $old_data->{$key};
3308 next unless defined $old_data->{$key};
3309 if (not defined $new_data->{$key} or
3310 not exists $Debbugs::Status::fields{$key}) {
3311 delete $new_data->{$key};
3314 if (ref($new_data->{$key}) and
3315 ref($old_data->{$key}) and
3316 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3317 local $Storable::canonical = 1;
3318 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3319 delete $new_data->{$key};
3320 delete $old_data->{$key};
3323 elsif ($new_data->{$key} eq $old_data->{$key}) {
3324 delete $new_data->{$key};
3325 delete $old_data->{$key};
3328 $data_diff .= "<!-- new_data:\n";
3330 for my $key (keys %{$new_data}) {
3331 if (not exists $Debbugs::Status::fields{$key}) {
3332 warn "No such field $key";
3335 $nd{$key} = $new_data->{$key};
3336 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3338 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3339 $data_diff .= "-->\n";
3340 $data_diff .= "<!-- old_data:\n";
3342 for my $key (keys %{$old_data}) {
3343 if (not exists $Debbugs::Status::fields{$key}) {
3344 warn "No such field $key";
3347 $od{$key} = $old_data->{$key};
3348 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3350 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3351 $data_diff .= "-->\n";
3354 (exists $param{command} ?
3355 "<!-- command:".html_escape($param{command})." -->\n":""
3357 (length $param{requester} ?
3358 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3360 (length $param{request_addr} ?
3361 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3363 "<!-- time:".time()." -->\n",
3365 "<strong>".html_escape($param{action})."</strong>\n");
3366 if (length $param{requester}) {
3367 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3369 if (length $param{request_addr}) {
3370 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3372 if (length $param{desc}) {
3373 $msg .= ":<br>\n$param{desc}\n";
3378 push @records, {type => 'html',
3382 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3383 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3384 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3385 text => join('',make_list($param{message})),
3388 write_log_records(logfh=>$logfh,
3389 records => \@records,
3391 close $logfh or die "Unable to close $log_location: $!";
3392 if ($param{get_lock}) {
3393 unfilelock(exists $param{locks}?$param{locks}:());
3401 =head1 PRIVATE FUNCTIONS
3403 =head2 __handle_affected_packages
3405 __handle_affected_packages(affected_packages => {},
3413 sub __handle_affected_packages{
3414 my %param = validate_with(params => \@_,
3415 spec => {%common_options,
3416 data => {type => ARRAYREF|HASHREF
3421 for my $data (make_list($param{data})) {
3422 next unless exists $data->{package} and defined $data->{package};
3423 my @packages = split /\s*,\s*/,$data->{package};
3424 @{$param{affected_packages}}{@packages} = (1) x @packages;
3428 =head2 __handle_debug_transcript
3430 my ($debug,$transcript) = __handle_debug_transcript(%param);
3432 Returns a debug and transcript filehandle
3437 sub __handle_debug_transcript{
3438 my %param = validate_with(params => \@_,
3439 spec => {%common_options},
3442 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3443 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3444 return ($debug,$transcript);
3451 Produces a small bit of bug information to kick out to the transcript
3458 next unless defined $data and exists $data->{bug_num};
3459 $return .= "Bug #".($data->{bug_num}||'').
3460 ((defined $data->{done} and length $data->{done})?
3461 " {Done: $data->{done}}":''
3463 " [".($data->{package}||'(no package)'). "] ".
3464 ($data->{subject}||'(no subject)')."\n";
3470 =head2 __internal_request
3472 __internal_request()
3473 __internal_request($level)
3475 Returns true if the caller of the function calling __internal_request
3476 belongs to __PACKAGE__
3478 This allows us to be magical, and don't bother to print bug info if
3479 the second caller is from this package, amongst other things.
3481 An optional level is allowed, which increments the number of levels to
3482 check by the given value. [This is basically for use by internal
3483 functions like __begin_control which are always called by
3488 sub __internal_request{
3490 $l = 0 if not defined $l;
3491 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3497 sub __return_append_to_log_options{
3499 my $action = $param{action} if exists $param{action};
3500 if (not exists $param{requester}) {
3501 $param{requester} = $config{control_internal_requester};
3503 if (not exists $param{request_addr}) {
3504 $param{request_addr} = $config{control_internal_request_addr};
3506 if (not exists $param{message}) {
3507 my $date = rfc822_date();
3508 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3509 variables => {request_addr => $param{request_addr},
3510 requester => $param{requester},
3516 if (not defined $action) {
3517 carp "Undefined action!";
3518 $action = "unknown action";
3520 return (action => $action,
3521 hash_slice(%param,keys %append_action_options),
3525 =head2 __begin_control
3527 my %info = __begin_control(%param,
3529 command=>'unarchive');
3530 my ($debug,$transcript) = @info{qw(debug transcript)};
3531 my @data = @{$info{data}};
3532 my @bugs = @{$info{bugs}};
3535 Starts the process of modifying a bug; handles all of the generic
3536 things that almost every control request needs
3538 Returns a hash containing
3542 =item new_locks -- number of new locks taken out by this call
3544 =item debug -- the debug file handle
3546 =item transcript -- the transcript file handle
3548 =item data -- an arrayref containing the data of the bugs
3549 corresponding to this request
3551 =item bugs -- an arrayref containing the bug numbers of the bugs
3552 corresponding to this request
3560 sub __begin_control {
3561 my %param = validate_with(params => \@_,
3562 spec => {bug => {type => SCALAR,
3565 archived => {type => BOOLEAN,
3568 command => {type => SCALAR,
3576 my ($debug,$transcript) = __handle_debug_transcript(@_);
3577 print {$debug} "$param{bug} considering\n";
3578 $lockhash = $param{locks} if exists $param{locks};
3580 my $old_die = $SIG{__DIE__};
3581 $SIG{__DIE__} = *sig_die{CODE};
3583 ($new_locks, @data) =
3584 lock_read_all_merged_bugs(bug => $param{bug},
3585 $param{archived}?(location => 'archive'):(),
3586 exists $param{locks} ? (locks => $param{locks}):(),
3588 $locks += $new_locks;
3590 die "Unable to read any bugs successfully.";
3592 if (not $param{archived}) {
3593 for my $data (@data) {
3594 if ($data->{archived}) {
3595 die "Not altering archived bugs; see unarchive.";
3599 if (not __check_limit(data => \@data,
3600 exists $param{limit}?(limit => $param{limit}):(),
3601 transcript => $transcript,
3603 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3606 __handle_affected_packages(%param,data => \@data);
3607 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3608 print {$debug} "$param{bug} read $locks locks\n";
3609 if (not @data or not defined $data[0]) {
3610 print {$transcript} "No bug found for $param{bug}\n";
3611 die "No bug found for $param{bug}";
3614 add_recipients(data => \@data,
3615 recipients => $param{recipients},
3616 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3618 (__internal_request()?(transcript => $transcript):()),
3621 print {$debug} "$param{bug} read done\n";
3622 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3623 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3624 return (data => \@data,
3626 old_die => $old_die,
3627 new_locks => $new_locks,
3629 transcript => $transcript,
3631 exists $param{locks}?(locks => $param{locks}):(),
3635 =head2 __end_control
3637 __end_control(%info);
3639 Handles tearing down from a control request
3645 if (exists $info{new_locks} and $info{new_locks} > 0) {
3646 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3647 for (1..$info{new_locks}) {
3648 unfilelock(exists $info{locks}?$info{locks}:());
3652 $SIG{__DIE__} = $info{old_die};
3653 if (exists $info{param}{affected_bugs}) {
3654 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3656 add_recipients(recipients => $info{param}{recipients},
3657 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3658 data => $info{data},
3659 debug => $info{debug},
3660 transcript => $info{transcript},
3662 __handle_affected_packages(%{$info{param}},data=>$info{data});
3666 =head2 __check_limit
3668 __check_limit(data => \@data, limit => $param{limit});
3671 Checks to make sure that bugs match any limits; each entry of @data
3672 much satisfy the limit.
3674 Returns true if there are no entries in data, or there are no keys in
3675 limit; returns false (0) if there are any entries which do not match.
3677 The limit hashref elements can contain an arrayref of scalars to
3678 match; regexes are also acccepted. At least one of the entries in each
3679 element needs to match the corresponding field in all data for the
3686 my %param = validate_with(params => \@_,
3687 spec => {data => {type => ARRAYREF|SCALAR,
3689 limit => {type => HASHREF|UNDEF,
3691 transcript => {type => SCALARREF|HANDLE,
3696 my @data = make_list($param{data});
3698 not defined $param{limit} or
3699 not keys %{$param{limit}}) {
3702 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3703 my $going_to_fail = 0;
3704 for my $data (@data) {
3705 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3706 status => dclone($data),
3708 for my $field (keys %{$param{limit}}) {
3709 next unless exists $param{limit}{$field};
3711 my @data_fields = make_list($data->{$field});
3712 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3713 if (not ref $limit) {
3714 for my $data_field (@data_fields) {
3715 if ($data_field eq $limit) {
3721 elsif (ref($limit) eq 'Regexp') {
3722 for my $data_field (@data_fields) {
3723 if ($data_field =~ $limit) {
3730 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3735 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3736 "' does not match at least one of ".
3737 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3741 return $going_to_fail?0:1;
3749 We override die to specially handle unlocking files in the cases where
3750 we are called via eval. [If we're not called via eval, it doesn't
3756 if ($^S) { # in eval
3758 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3765 # =head2 __message_body_template
3767 # message_body_template('mail/ack',{ref=>'foo'});
3769 # Creates a message body using a template
3773 sub __message_body_template{
3774 my ($template,$extra_var) = @_;
3776 my $hole_var = {'&bugurl' =>
3778 'http://'.$config{cgi_domain}.'/'.
3779 Debbugs::CGI::bug_url($_[0]);
3783 my $body = fill_in_template(template => $template,
3784 variables => {config => \%config,
3787 hole_var => $hole_var,
3789 return fill_in_template(template => 'mail/message_body',
3790 variables => {config => \%config,
3794 hole_var => $hole_var,
3798 sub __all_undef_or_equal {
3800 return 1 if @values == 1 or @values == 0;
3801 my $not_def = grep {not defined $_} @values;
3802 if ($not_def == @values) {
3805 if ($not_def > 0 and $not_def != @values) {
3808 my $first_val = shift @values;
3809 for my $val (@values) {
3810 if ($first_val ne $val) {