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";
465 $data->{blockedby} = join(' ',keys %blockers);
466 append_action_to_log(bug => $data->{bug_num},
468 old_data => $old_data,
471 __return_append_to_log_options(
476 if not exists $param{append_log} or $param{append_log};
477 writebug($data->{bug_num},$data);
478 print {$transcript} "$action\n";
480 # we do this bit below to avoid code duplication
482 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
483 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
485 for my $add_remove (keys %mungable_blocks) {
489 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
490 next if $munge_blockers{$blocker};
491 my ($temp_locks, @blocking_data) =
492 lock_read_all_merged_bugs(bug => $blocker,
493 ($param{archived}?(location => 'archive'):()),
494 exists $param{locks}?(locks => $param{locks}):(),
496 $locks+= $temp_locks;
497 $new_locks+=$temp_locks;
498 if (not @blocking_data) {
499 for (1..$new_locks) {
500 unfilelock(exists $param{locks}?$param{locks}:());
503 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
505 for (map {$_->{bug_num}} @blocking_data) {
506 $munge_blockers{$_} = 1;
508 for my $data (@blocking_data) {
509 my $old_data = dclone($data);
511 my @blocks = split ' ', $data->{blocks};
512 @blocks{@blocks} = (1) x @blocks;
514 for my $bug (@bugs) {
515 if ($add_remove eq 'remove') {
516 next unless exists $blocks{$bug};
517 delete $blocks{$bug};
520 next if exists $blocks{$bug};
525 $data->{blocks} = join(' ',sort keys %blocks);
526 my $action = ($add_remove eq 'add'?'Added':'Removed').
527 " indication that bug $data->{bug_num} blocks ".
529 append_action_to_log(bug => $data->{bug_num},
531 old_data => $old_data,
534 __return_append_to_log_options(%param,
538 writebug($data->{bug_num},$data);
540 __handle_affected_packages(%param,data=>\@blocking_data);
541 add_recipients(recipients => $param{recipients},
542 actions_taken => {blocks => 1},
543 data => \@blocking_data,
545 transcript => $transcript,
548 for (1..$new_locks) {
549 unfilelock(exists $param{locks}?$param{locks}:());
554 __end_control(%info);
563 transcript => $transcript,
564 ($dl > 0 ? (debug => $transcript):()),
565 requester => $header{from},
566 request_addr => $controlrequestaddr,
568 affected_packages => \%affected_packages,
569 recipients => \%recipients,
576 print {$transcript} "Failed to set tag on $ref: $@";
580 Sets, adds, or removes the specified tags on a bug
584 =item tag -- scalar or arrayref of tags to set, add or remove
586 =item add -- if true, add tags
588 =item remove -- if true, remove tags
590 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
598 my %param = validate_with(params => \@_,
599 spec => {bug => {type => SCALAR,
602 # specific options here
603 tag => {type => SCALAR|ARRAYREF,
606 add => {type => BOOLEAN,
609 remove => {type => BOOLEAN,
612 warn_on_bad_tags => {type => BOOLEAN,
616 %append_action_options,
619 if ($param{add} and $param{remove}) {
620 croak "It's nonsensical to add and remove the same tags";
624 __begin_control(%param,
627 my ($debug,$transcript) =
628 @info{qw(debug transcript)};
629 my @data = @{$info{data}};
630 my @bugs = @{$info{bugs}};
631 my @tags = make_list($param{tag});
632 if (not @tags and ($param{remove} or $param{add})) {
633 if ($param{remove}) {
634 print {$transcript} "Requested to remove no tags; doing nothing.\n";
637 print {$transcript} "Requested to add no tags; doing nothing.\n";
639 __end_control(%info);
642 # first things first, make the versions fully qualified source
644 for my $data (@data) {
645 my $action = 'Did not alter tags';
647 my %tag_removed = ();
648 my %fixed_removed = ();
649 my @old_tags = split /\,?\s+/, $data->{keywords};
651 @tags{@old_tags} = (1) x @old_tags;
653 my $old_data = dclone($data);
654 if (not $param{add} and not $param{remove}) {
655 $tag_removed{$_} = 1 for @old_tags;
659 for my $tag (@tags) {
660 if (not $param{remove} and
661 not defined first {$_ eq $tag} @{$config{tags}}) {
662 push @bad_tags, $tag;
666 if (not exists $tags{$tag}) {
668 $tag_added{$tag} = 1;
671 elsif ($param{remove}) {
672 if (exists $tags{$tag}) {
674 $tag_removed{$tag} = 1;
678 if (exists $tag_removed{$tag}) {
679 delete $tag_removed{$tag};
682 $tag_added{$tag} = 1;
687 if (@bad_tags and $param{warn_on_bad_tags}) {
688 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
689 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
691 $data->{keywords} = join(' ',keys %tags);
694 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
695 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
696 $action = ucfirst(join ('; ',@changed)) if @changed;
698 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n";
702 append_action_to_log(bug => $data->{bug_num},
705 old_data => $old_data,
707 __return_append_to_log_options(
712 if not exists $param{append_log} or $param{append_log};
713 writebug($data->{bug_num},$data);
714 print {$transcript} "$action\n";
716 __end_control(%info);
724 set_severity(bug => $ref,
725 transcript => $transcript,
726 ($dl > 0 ? (debug => $transcript):()),
727 requester => $header{from},
728 request_addr => $controlrequestaddr,
730 affected_packages => \%affected_packages,
731 recipients => \%recipients,
732 severity => 'normal',
737 print {$transcript} "Failed to set the severity of bug $ref: $@";
740 Sets the severity of a bug. If severity is not passed, is undefined,
741 or has zero length, sets the severity to the default severity.
746 my %param = validate_with(params => \@_,
747 spec => {bug => {type => SCALAR,
750 # specific options here
751 severity => {type => SCALAR|UNDEF,
752 default => $config{default_severity},
755 %append_action_options,
758 if (not defined $param{severity} or
759 not length $param{severity}
761 $param{severity} = $config{default_severity};
764 # check validity of new severity
765 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
766 die "Severity '$param{severity}' is not a valid severity level";
769 __begin_control(%param,
770 command => 'severity'
772 my ($debug,$transcript) =
773 @info{qw(debug transcript)};
774 my @data = @{$info{data}};
775 my @bugs = @{$info{bugs}};
778 for my $data (@data) {
779 if (not defined $data->{severity}) {
780 $data->{severity} = $param{severity};
781 $action = "Severity set to '$param{severity}'";
784 if ($data->{severity} eq '') {
785 $data->{severity} = $config{default_severity};
787 if ($data->{severity} eq $param{severity}) {
788 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
791 $action = "Severity set to '$param{severity}' from '$data->{severity}'";
792 $data->{severity} = $param{severity};
794 append_action_to_log(bug => $data->{bug_num},
796 __return_append_to_log_options(
801 if not exists $param{append_log} or $param{append_log};
802 writebug($data->{bug_num},$data);
803 print {$transcript} "$action\n";
805 __end_control(%info);
812 set_done(bug => $ref,
813 transcript => $transcript,
814 ($dl > 0 ? (debug => $transcript):()),
815 requester => $header{from},
816 request_addr => $controlrequestaddr,
818 affected_packages => \%affected_packages,
819 recipients => \%recipients,
824 print {$transcript} "Failed to set foo $ref bar: $@";
832 my %param = validate_with(params => \@_,
833 spec => {bug => {type => SCALAR,
836 reopen => {type => BOOLEAN,
839 submitter => {type => SCALAR,
842 clear_fixed => {type => BOOLEAN,
845 notify_submitter => {type => BOOLEAN,
848 original_report => {type => SCALARREF,
851 done => {type => SCALAR|UNDEF,
855 %append_action_options,
859 if (exists $param{submitter} and
860 not Mail::RFC822::Address::valid($param{submitter})) {
861 die "New submitter address '$param{submitter}' is not a valid e-mail address";
863 if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address
864 $param{done} = $param{requester};
866 if (exists $param{done} and
867 (not defined $param{done} or
868 not length $param{done})) {
874 __begin_control(%param,
875 command => $param{reopen}?'reopen':'done',
877 my ($debug,$transcript) =
878 @info{qw(debug transcript)};
879 my @data = @{$info{data}};
880 my @bugs = @{$info{bugs}};
883 if ($param{reopen}) {
884 # avoid warning multiple times if there are fixed versions
886 for my $data (@data) {
887 if (not exists $data->{done} or
888 not defined $data->{done} or
889 not length $data->{done}) {
890 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
891 __end_control(%info);
894 if (@{$data->{fixed_versions}} and $warn_fixed) {
895 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
896 print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n";
900 $action = "Bug reopened";
901 for my $data (@data) {
902 my $old_data = dclone($data);
904 append_action_to_log(bug => $data->{bug_num},
907 old_data => $old_data,
909 __return_append_to_log_options(
914 if not exists $param{append_log} or $param{append_log};
915 writebug($data->{bug_num},$data);
917 print {$transcript} "$action\n";
918 __end_control(%info);
919 if (exists $param{submitter}) {
920 set_submitter(bug => $param{bug},
921 submitter => $param{submitter},
923 keys %common_options,
924 keys %append_action_options)
927 # clear the fixed revisions
928 if ($param{clear_fixed}) {
929 set_fixed(fixed => [],
933 keys %common_options,
934 keys %append_action_options),
939 my %submitter_notified;
940 my $requester_notified = 0;
941 my $orig_report_set = 0;
942 for my $data (@data) {
943 if (exists $data->{done} and
944 defined $data->{done} and
945 length $data->{done}) {
946 print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
947 __end_control(%info);
951 for my $data (@data) {
952 my $old_data = dclone($data);
953 my $hash = get_hashname($data->{bug_num});
954 my $report_fh = IO::File->new("db-h/$hash/$data->{bug_num}.report",'r') or
955 die "Unable to open original report db-h/$hash/$data->{bug_num}.report for reading: $!";
959 $orig_report= <$report_fh>;
962 if (not $orig_report_set and defined $orig_report and
963 length $orig_report and
964 exists $param{original_report}){
965 ${$param{original_report}} = $orig_report;
966 $orig_report_set = 1;
969 $action = "Marked $config{bug} as done";
971 # set done to the requester
972 $data->{done} = exists $param{done}?$param{done}:$param{requester};
973 append_action_to_log(bug => $data->{bug_num},
976 old_data => $old_data,
978 __return_append_to_log_options(
983 if not exists $param{append_log} or $param{append_log};
984 writebug($data->{bug_num},$data);
985 print {$transcript} "$action\n";
986 # get the original report
987 if ($param{notify_submitter}) {
988 my $submitter_message;
989 if(not exists $submitter_notified{$data->{originator}}) {
991 create_mime_message([default_headers(queue_file => $param{request_nn},
993 msgid => $param{request_msgid},
994 msgtype => 'notifdone',
995 pr_msg => 'they-closed',
997 [To => $data->{submitter},
998 Subject => "$config{ubug}#$data->{bug_num} ".
999 "closed by $param{requester} ($param{request_subject})",
1003 __message_body_template('mail/process_your_bug_done',
1005 replyto => (exists $param{request_replyto} ?
1006 $param{request_replyto} :
1007 $param{requester} || 'Unknown'),
1008 markedby => $param{requester},
1009 subject => $param{request_subject},
1010 messageid => $param{request_msgid},
1013 [join('',make_list($param{message})),$orig_report]
1015 send_mail_message(message => $submitter_message,
1016 recipients => $old_data->{submitter},
1018 $submitter_notified{$data->{originator}} = $submitter_message;
1021 $submitter_message = $submitter_notified{$data->{originator}};
1023 append_action_to_log(bug => $data->{bug_num},
1024 action => "Notification sent",
1026 request_addr => $data->{originator},
1027 desc => "$config{bug} acknowledged by developer.",
1028 recips => [$data->{originator}],
1029 message => $submitter_message,
1034 __end_control(%info);
1035 if (exists $param{fixed}) {
1036 set_fixed(fixed => $param{fixed},
1040 keys %common_options,
1041 keys %append_action_options
1049 =head2 set_submitter
1052 set_submitter(bug => $ref,
1053 transcript => $transcript,
1054 ($dl > 0 ? (debug => $transcript):()),
1055 requester => $header{from},
1056 request_addr => $controlrequestaddr,
1058 affected_packages => \%affected_packages,
1059 recipients => \%recipients,
1060 submitter => $new_submitter,
1061 notify_submitter => 1,
1066 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1069 Sets the submitter of a bug. If notify_submitter is true (the
1070 default), notifies the old submitter of a bug on changes
1075 my %param = validate_with(params => \@_,
1076 spec => {bug => {type => SCALAR,
1079 # specific options here
1080 submitter => {type => SCALAR,
1082 notify_submitter => {type => BOOLEAN,
1086 %append_action_options,
1089 if (not Mail::RFC822::Address::valid($param{submitter})) {
1090 die "New submitter address $param{submitter} is not a valid e-mail address";
1093 __begin_control(%param,
1094 command => 'submitter'
1096 my ($debug,$transcript) =
1097 @info{qw(debug transcript)};
1098 my @data = @{$info{data}};
1099 my @bugs = @{$info{bugs}};
1101 # here we only concern ourselves with the first of the merged bugs
1102 for my $data ($data[0]) {
1103 my $notify_old_submitter = 0;
1104 my $old_data = dclone($data);
1105 print {$debug} "Going to change bug submitter\n";
1106 if (((not defined $param{submitter} or not length $param{submitter}) and
1107 (not defined $data->{originator} or not length $data->{originator})) or
1108 (defined $param{submitter} and defined $data->{originator} and
1109 $param{submitter} eq $data->{originator})) {
1110 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n";
1114 if (defined $data->{originator} and length($data->{originator})) {
1115 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
1116 $notify_old_submitter = 1;
1119 $action= "Set $config{bug} submitter to '$param{submitter}'.";
1121 $data->{originator} = $param{submitter};
1123 append_action_to_log(bug => $data->{bug_num},
1124 command => 'submitter',
1126 old_data => $old_data,
1128 __return_append_to_log_options(
1133 if not exists $param{append_log} or $param{append_log};
1134 writebug($data->{bug_num},$data);
1135 print {$transcript} "$action\n";
1136 # notify old submitter
1137 if ($notify_old_submitter and $param{notify_submitter}) {
1138 send_mail_message(message =>
1139 create_mime_message([default_headers(queue_file => $param{request_nn},
1141 msgid => $param{request_msgid},
1143 pr_msg => 'submitter-changed',
1145 [To => $old_data->{submitter},
1146 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
1150 __message_body_template('mail/submitter_changed',
1151 {old_data => $old_data,
1153 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
1157 recipients => $old_data->{submitter},
1161 __end_control(%info);
1166 =head2 set_forwarded
1169 set_forwarded(bug => $ref,
1170 transcript => $transcript,
1171 ($dl > 0 ? (debug => $transcript):()),
1172 requester => $header{from},
1173 request_addr => $controlrequestaddr,
1175 affected_packages => \%affected_packages,
1176 recipients => \%recipients,
1177 forwarded => $forward_to,
1182 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1185 Sets the location to which a bug is forwarded. Given an undef
1186 forwarded, unsets forwarded.
1192 my %param = validate_with(params => \@_,
1193 spec => {bug => {type => SCALAR,
1196 # specific options here
1197 forwarded => {type => SCALAR|UNDEF,
1200 %append_action_options,
1203 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1204 die "Non-printable characters are not allowed in the forwarded field";
1206 $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
1208 __begin_control(%param,
1209 command => 'forwarded'
1211 my ($debug,$transcript) =
1212 @info{qw(debug transcript)};
1213 my @data = @{$info{data}};
1214 my @bugs = @{$info{bugs}};
1216 for my $data (@data) {
1217 my $old_data = dclone($data);
1218 print {$debug} "Going to change bug forwarded\n";
1219 if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
1220 (not defined $param{forwarded} and
1221 defined $data->{forwarded} and not length $data->{forwarded})) {
1222 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n";
1226 if (not defined $param{forwarded}) {
1227 $action= "Unset $config{bug} forwarded-to-address";
1229 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1230 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1233 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1235 $data->{forwarded} = $param{forwarded};
1237 append_action_to_log(bug => $data->{bug_num},
1238 command => 'forwarded',
1240 old_data => $old_data,
1242 __return_append_to_log_options(
1247 if not exists $param{append_log} or $param{append_log};
1248 writebug($data->{bug_num},$data);
1249 print {$transcript} "$action\n";
1251 __end_control(%info);
1260 set_title(bug => $ref,
1261 transcript => $transcript,
1262 ($dl > 0 ? (debug => $transcript):()),
1263 requester => $header{from},
1264 request_addr => $controlrequestaddr,
1266 affected_packages => \%affected_packages,
1267 recipients => \%recipients,
1268 title => $new_title,
1273 print {$transcript} "Failed to set the title of $ref: $@";
1276 Sets the title of a specific bug
1282 my %param = validate_with(params => \@_,
1283 spec => {bug => {type => SCALAR,
1286 # specific options here
1287 title => {type => SCALAR,
1290 %append_action_options,
1293 if ($param{title} =~ /[^[:print:]]/) {
1294 die "Non-printable characters are not allowed in bug titles";
1297 my %info = __begin_control(%param,
1300 my ($debug,$transcript) =
1301 @info{qw(debug transcript)};
1302 my @data = @{$info{data}};
1303 my @bugs = @{$info{bugs}};
1305 for my $data (@data) {
1306 my $old_data = dclone($data);
1307 print {$debug} "Going to change bug title\n";
1308 if (defined $data->{subject} and length($data->{subject}) and
1309 $data->{subject} eq $param{title}) {
1310 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n";
1314 if (defined $data->{subject} and length($data->{subject})) {
1315 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1317 $action= "Set $config{bug} title to '$param{title}'.";
1319 $data->{subject} = $param{title};
1321 append_action_to_log(bug => $data->{bug_num},
1324 old_data => $old_data,
1326 __return_append_to_log_options(
1331 if not exists $param{append_log} or $param{append_log};
1332 writebug($data->{bug_num},$data);
1333 print {$transcript} "$action\n";
1335 __end_control(%info);
1342 set_package(bug => $ref,
1343 transcript => $transcript,
1344 ($dl > 0 ? (debug => $transcript):()),
1345 requester => $header{from},
1346 request_addr => $controlrequestaddr,
1348 affected_packages => \%affected_packages,
1349 recipients => \%recipients,
1350 package => $new_package,
1356 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1359 Indicates that a bug is in a particular package. If is_source is true,
1360 indicates that the package is a source package. [Internally, this
1361 causes src: to be prepended to the package name.]
1363 The default for is_source is 0. As a special case, if the package
1364 starts with 'src:', it is assumed to be a source package and is_source
1367 The package option must match the package_name_re regex.
1372 my %param = validate_with(params => \@_,
1373 spec => {bug => {type => SCALAR,
1376 # specific options here
1377 package => {type => SCALAR|ARRAYREF,
1379 is_source => {type => BOOLEAN,
1383 %append_action_options,
1386 my @new_packages = map {splitpackages($_)} make_list($param{package});
1387 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1388 croak "Invalid package name '".
1389 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1392 my %info = __begin_control(%param,
1393 command => 'package',
1395 my ($debug,$transcript) =
1396 @info{qw(debug transcript)};
1397 my @data = @{$info{data}};
1398 my @bugs = @{$info{bugs}};
1399 # clean up the new package
1403 ($temp =~ s/^src:// or
1404 $param{is_source}) ? 'src:'.$temp:$temp;
1408 my $package_reassigned = 0;
1409 for my $data (@data) {
1410 my $old_data = dclone($data);
1411 print {$debug} "Going to change assigned package\n";
1412 if (defined $data->{package} and length($data->{package}) and
1413 $data->{package} eq $new_package) {
1414 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n";
1418 if (defined $data->{package} and length($data->{package})) {
1419 $package_reassigned = 1;
1420 $action= "$config{bug} reassigned from package '$data->{package}'".
1421 " to '$new_package'.";
1423 $action= "$config{bug} assigned to package '$new_package'.";
1425 $data->{package} = $new_package;
1427 append_action_to_log(bug => $data->{bug_num},
1428 command => 'package',
1430 old_data => $old_data,
1432 __return_append_to_log_options(
1437 if not exists $param{append_log} or $param{append_log};
1438 writebug($data->{bug_num},$data);
1439 print {$transcript} "$action\n";
1441 __end_control(%info);
1442 # Only clear the fixed/found versions if the package has been
1444 if ($package_reassigned) {
1445 my @params_for_found_fixed =
1446 map {exists $param{$_}?($_,$param{$_}):()}
1448 keys %common_options,
1449 keys %append_action_options,
1451 set_found(found => [],
1452 @params_for_found_fixed,
1454 set_fixed(fixed => [],
1455 @params_for_found_fixed,
1463 set_found(bug => $ref,
1464 transcript => $transcript,
1465 ($dl > 0 ? (debug => $transcript):()),
1466 requester => $header{from},
1467 request_addr => $controlrequestaddr,
1469 affected_packages => \%affected_packages,
1470 recipients => \%recipients,
1477 print {$transcript} "Failed to set found on $ref: $@";
1481 Sets, adds, or removes the specified found versions of a package
1483 If the version list is empty, and the bug is currently not "done",
1484 causes the done field to be cleared.
1486 If any of the versions added to found are greater than any version in
1487 which the bug is fixed (or when the bug is found and there are no
1488 fixed versions) the done field is cleared.
1493 my %param = validate_with(params => \@_,
1494 spec => {bug => {type => SCALAR,
1497 # specific options here
1498 found => {type => SCALAR|ARRAYREF,
1501 add => {type => BOOLEAN,
1504 remove => {type => BOOLEAN,
1508 %append_action_options,
1511 if ($param{add} and $param{remove}) {
1512 croak "It's nonsensical to add and remove the same versions";
1516 __begin_control(%param,
1519 my ($debug,$transcript) =
1520 @info{qw(debug transcript)};
1521 my @data = @{$info{data}};
1522 my @bugs = @{$info{bugs}};
1524 for my $version (make_list($param{found})) {
1525 next unless defined $version;
1526 $versions{$version} =
1527 [make_source_versions(package => [splitpackages($data[0]{package})],
1528 warnings => $transcript,
1531 versions => $version,
1534 # This is really ugly, but it's what we have to do
1535 if (not @{$versions{$version}}) {
1536 print {$transcript} "Unable to make a source version for version '$version'\n";
1539 if (not keys %versions and ($param{remove} or $param{add})) {
1540 if ($param{remove}) {
1541 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1544 print {$transcript} "Requested to add no versions; doing nothing.\n";
1546 __end_control(%info);
1549 # first things first, make the versions fully qualified source
1551 for my $data (@data) {
1552 # The 'done' field gets a bit weird with version tracking,
1553 # because a bug may be closed by multiple people in different
1554 # branches. Until we have something more flexible, we set it
1555 # every time a bug is fixed, and clear it when a bug is found
1556 # in a version greater than any version in which the bug is
1557 # fixed or when a bug is found and there is no fixed version
1558 my $action = 'Did not alter found versions';
1559 my %found_added = ();
1560 my %found_removed = ();
1561 my %fixed_removed = ();
1563 my $old_data = dclone($data);
1564 if (not $param{add} and not $param{remove}) {
1565 $found_removed{$_} = 1 for @{$data->{found_versions}};
1566 $data->{found_versions} = [];
1569 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1571 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1572 for my $version (keys %versions) {
1574 my @svers = @{$versions{$version}};
1579 if (exists $found_versions{$version}) {
1580 delete $found_versions{$version};
1581 $found_removed{$version} = 1;
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";
1656 append_action_to_log(bug => $data->{bug_num},
1659 old_data => $old_data,
1661 __return_append_to_log_options(
1666 if not exists $param{append_log} or $param{append_log};
1667 writebug($data->{bug_num},$data);
1668 print {$transcript} "$action\n";
1670 __end_control(%info);
1676 set_fixed(bug => $ref,
1677 transcript => $transcript,
1678 ($dl > 0 ? (debug => $transcript):()),
1679 requester => $header{from},
1680 request_addr => $controlrequestaddr,
1682 affected_packages => \%affected_packages,
1683 recipients => \%recipients,
1691 print {$transcript} "Failed to set fixed on $ref: $@";
1695 Sets, adds, or removes the specified fixed versions of a package
1697 If the fixed versions are empty (or end up being empty after this
1698 call) or the greatest fixed version is less than the greatest found
1699 version and the reopen option is true, the bug is reopened.
1701 This function is also called by the reopen function, which causes all
1702 of the fixed versions to be cleared.
1707 my %param = validate_with(params => \@_,
1708 spec => {bug => {type => SCALAR,
1711 # specific options here
1712 fixed => {type => SCALAR|ARRAYREF,
1715 add => {type => BOOLEAN,
1718 remove => {type => BOOLEAN,
1721 reopen => {type => BOOLEAN,
1725 %append_action_options,
1728 if ($param{add} and $param{remove}) {
1729 croak "It's nonsensical to add and remove the same versions";
1732 __begin_control(%param,
1735 my ($debug,$transcript) =
1736 @info{qw(debug transcript)};
1737 my @data = @{$info{data}};
1738 my @bugs = @{$info{bugs}};
1740 for my $version (make_list($param{fixed})) {
1741 next unless defined $version;
1742 $versions{$version} =
1743 [make_source_versions(package => [splitpackages($data[0]{package})],
1744 warnings => $transcript,
1747 versions => $version,
1750 # This is really ugly, but it's what we have to do
1751 if (not @{$versions{$version}}) {
1752 print {$transcript} "Unable to make a source version for version '$version'\n";
1755 if (not keys %versions and ($param{remove} or $param{add})) {
1756 if ($param{remove}) {
1757 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1760 print {$transcript} "Requested to add no versions; doing nothing.\n";
1762 __end_control(%info);
1765 # first things first, make the versions fully qualified source
1767 for my $data (@data) {
1768 my $old_data = dclone($data);
1769 # The 'done' field gets a bit weird with version tracking,
1770 # because a bug may be closed by multiple people in different
1771 # branches. Until we have something more flexible, we set it
1772 # every time a bug is fixed, and clear it when a bug is found
1773 # in a version greater than any version in which the bug is
1774 # fixed or when a bug is found and there is no fixed version
1775 my $action = 'Did not alter fixed versions';
1776 my %found_added = ();
1777 my %found_removed = ();
1778 my %fixed_added = ();
1779 my %fixed_removed = ();
1781 if (not $param{add} and not $param{remove}) {
1782 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1783 $data->{fixed_versions} = [];
1786 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1788 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1789 for my $version (keys %versions) {
1791 my @svers = @{$versions{$version}};
1796 if (exists $fixed_versions{$version}) {
1797 $fixed_removed{$version} = 1;
1798 delete $fixed_versions{$version};
1801 for my $sver (@svers) {
1802 if (not exists $fixed_versions{$sver}) {
1803 $fixed_versions{$sver} = 1;
1804 $fixed_added{$sver} = 1;
1808 elsif ($param{remove}) {
1809 # in the case of removal, we only concern ourself with
1810 # the version passed, not the source version it maps
1812 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1813 delete $fixed_versions{$_} for @temp;
1814 $fixed_removed{$_} = 1 for @temp;
1817 # set the keys to exactly these values
1818 my @svers = @{$versions{$version}};
1822 for my $sver (@svers) {
1823 if (not exists $fixed_versions{$sver}) {
1824 $fixed_versions{$sver} = 1;
1825 if (exists $fixed_removed{$sver}) {
1826 delete $fixed_removed{$sver};
1829 $fixed_added{$sver} = 1;
1836 $data->{found_versions} = [keys %found_versions];
1837 $data->{fixed_versions} = [keys %fixed_versions];
1839 # If we're supposed to consider reopening, reopen if the
1840 # fixed versions are empty or the greatest found version
1841 # is greater than the greatest fixed version
1842 if ($param{reopen} and defined $data->{done}
1843 and length $data->{done}) {
1844 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1845 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1846 # determine if we need to reopen
1847 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1848 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1849 if (not @fixed_order or
1850 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1857 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1858 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1859 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1860 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1861 $action = ucfirst(join ('; ',@changed)) if @changed;
1863 $action .= " and reopened"
1865 if (not $reopened and not @changed) {
1866 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n";
1870 append_action_to_log(bug => $data->{bug_num},
1873 old_data => $old_data,
1875 __return_append_to_log_options(
1880 if not exists $param{append_log} or $param{append_log};
1881 writebug($data->{bug_num},$data);
1882 print {$transcript} "$action\n";
1884 __end_control(%info);
1891 set_merged(bug => $ref,
1892 transcript => $transcript,
1893 ($dl > 0 ? (debug => $transcript):()),
1894 requester => $header{from},
1895 request_addr => $controlrequestaddr,
1897 affected_packages => \%affected_packages,
1898 recipients => \%recipients,
1899 merge_with => 12345,
1902 allow_reassign => 1,
1903 reassign_same_source_only => 1,
1908 print {$transcript} "Failed to set merged on $ref: $@";
1912 Sets, adds, or removes the specified merged bugs of a bug
1914 By default, requires
1919 my %param = validate_with(params => \@_,
1920 spec => {bug => {type => SCALAR,
1923 # specific options here
1924 merge_with => {type => ARRAYREF|SCALAR,
1927 remove => {type => BOOLEAN,
1930 force => {type => BOOLEAN,
1933 masterbug => {type => BOOLEAN,
1936 allow_reassign => {type => BOOLEAN,
1939 reassign_different_sources => {type => BOOLEAN,
1943 %append_action_options,
1946 my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1948 @merging{@merging} = (1) x @merging;
1949 if (grep {$_ !~ /^\d+$/} @merging) {
1950 croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1952 $param{locks} = {} if not exists $param{locks};
1954 __begin_control(%param,
1957 my ($debug,$transcript) =
1958 @info{qw(debug transcript)};
1959 if (not @merging and exists $param{merge_with}) {
1960 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1961 __end_control(%info);
1964 my @data = @{$info{data}};
1965 my @bugs = @{$info{bugs}};
1968 for my $data (@data) {
1969 $data{$data->{bug_num}} = $data;
1970 my @merged_bugs = split / /, $data->{mergedwith};
1971 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1975 if (not exists $param{merge_with}) {
1976 my $ok_to_unmerge = 1;
1977 delete $merged_bugs{$param{bug}};
1978 if (not keys %merged_bugs) {
1979 print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1980 __end_control(%info);
1983 my $action = "Disconnected #$param{bug} from all other report(s).";
1984 for my $data (@data) {
1985 my $old_data = dclone($data);
1986 if ($data->{bug_num} == $param{bug}) {
1987 $data->{mergedwith} = '';
1990 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
1993 append_action_to_log(bug => $data->{bug_num},
1996 old_data => $old_data,
1998 __return_append_to_log_options(%param,
2002 if not exists $param{append_log} or $param{append_log};
2003 writebug($data->{bug_num},$data);
2005 print {$transcript} "$action\n";
2006 __end_control(%info);
2009 # lock and load all of the bugs we need
2010 my @bugs_to_load = keys %merging;
2013 my ($data,$n_locks) =
2014 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2016 locks => $param{locks},
2019 $new_locks += $n_locks;
2021 @data = values %data;
2022 if (not __check_limit(data => [@data],
2023 exists $param{limit}?(limit => $param{limit}):(),
2024 transcript => $transcript,
2026 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2028 for my $data (@data) {
2029 $data{$data->{bug_num}} = $data;
2030 $merged_bugs{$data->{bug_num}} = 1;
2031 my @merged_bugs = split / /, $data->{mergedwith};
2032 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2033 if (exists $param{affected_bugs}) {
2034 $param{affected_bugs}{$data->{bug_num}} = 1;
2037 __handle_affected_packages(%param,data => [@data]);
2038 my %bug_info_shown; # which bugs have had information shown
2039 $bug_info_shown{$param{bug}} = 1;
2040 add_recipients(data => [@data],
2041 recipients => $param{recipients},
2042 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2044 (__internal_request()?(transcript => $transcript):()),
2047 # Figure out what the ideal state is for the bug,
2048 my ($merge_status,$bugs_to_merge) =
2049 __calculate_merge_status(\@data,\%data,$param{bug});
2050 # find out if we actually have any bugs to merge
2051 if (not $bugs_to_merge) {
2052 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2053 for (1..$new_locks) {
2054 unfilelock($param{locks});
2057 __end_control(%info);
2060 # see what changes need to be made to merge the bugs
2061 # check to make sure that the set of changes we need to make is allowed
2062 my ($disallowed_changes,$changes) =
2063 __calculate_merge_changes(\@data,$merge_status,\%param);
2064 # at this point, stop if there are disallowed changes, otherwise
2065 # make the allowed changes, and then reread the bugs in question
2066 # to get the new data, then recaculate the merges; repeat
2067 # reloading and recalculating until we try too many times or there
2068 # are no changes to make.
2071 # we will allow at most 4 times through this; more than 1
2072 # shouldn't really happen.
2074 while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2075 if ($attempts > 1) {
2076 print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2078 if (@{$disallowed_changes}) {
2079 # figure out the problems
2080 print {$transcript} "Unable to merge bugs because:\n";
2081 for my $change (@{$disallowed_changes}) {
2082 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2084 if ($attempts > 0) {
2085 croak "Some bugs were altered while attempting to merge";
2088 croak "Did not alter merged bugs";
2091 my ($change_bug) = keys %{$changes};
2092 $bug_changed{$change_bug}++;
2093 print {$transcript} __bug_info($data{$change_bug}) if
2094 $param{show_bug_info} and not __internal_request(1);
2095 $bug_info_shown{$change_bug} = 1;
2096 __allow_relocking($param{locks},[keys %data]);
2097 for my $change (@{$changes->{$change_bug}}) {
2098 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2099 my %target_blockedby;
2100 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2101 my %unhandled_targets = %target_blockedby;
2102 my @blocks_to_remove;
2103 for my $key (split / /,$change->{orig_value}) {
2104 delete $unhandled_targets{$key};
2105 next if exists $target_blockedby{$key};
2106 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2107 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2110 keys %common_options,
2111 keys %append_action_options),
2114 for my $key (keys %unhandled_targets) {
2115 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2116 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2119 keys %common_options,
2120 keys %append_action_options),
2125 $change->{function}->(bug => $change->{bug},
2126 $change->{key}, $change->{func_value},
2127 exists $change->{options}?@{$change->{options}}:(),
2129 keys %common_options,
2130 keys %append_action_options),
2134 __disallow_relocking($param{locks});
2135 my ($data,$n_locks) =
2136 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2138 locks => $param{locks},
2142 $new_locks += $n_locks;
2145 @data = values %data;
2146 ($merge_status,$bugs_to_merge) =
2147 __calculate_merge_status(\@data,\%data,$param{bug},$merge_status);
2148 ($disallowed_changes,$changes) =
2149 __calculate_merge_changes(\@data,$merge_status,\%param);
2150 $attempts = max(values %bug_changed);
2152 if ($param{show_bug_info} and not __internal_request(1)) {
2153 for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2154 next if $bug_info_shown{$data->{bug_num}};
2155 print {$transcript} __bug_info($data);
2158 if (keys %{$changes} or @{$disallowed_changes}) {
2159 print {$transcript} "After four attempts, the following changes were unable to be made:\n";
2160 for (1..$new_locks) {
2161 unfilelock($param{locks});
2164 __end_control(%info);
2165 for my $change (values %{$changes}, @{$disallowed_changes}) {
2166 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2168 die "Unable to modify bugs so they could be merged";
2172 # finally, we can merge the bugs
2173 my $action = "Merged ".join(' ',sort keys %merged_bugs);
2174 for my $data (@data) {
2175 my $old_data = dclone($data);
2176 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2178 append_action_to_log(bug => $data->{bug_num},
2181 old_data => $old_data,
2183 __return_append_to_log_options(%param,
2187 if not exists $param{append_log} or $param{append_log};
2188 writebug($data->{bug_num},$data);
2190 print {$transcript} "$action\n";
2191 # unlock the extra locks that we got earlier
2192 for (1..$new_locks) {
2193 unfilelock($param{locks});
2196 __end_control(%info);
2199 sub __allow_relocking{
2200 my ($locks,$bugs) = @_;
2202 my @locks = (@{$bugs},'merge');
2203 for my $lock (@locks) {
2204 my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}};
2205 next unless @lockfiles;
2206 $locks->{relockable}{$lockfiles[0]} = 0;
2210 sub __disallow_relocking{
2212 delete $locks->{relockable};
2215 sub __lock_and_load_merged_bugs{
2217 validate_with(params => \@_,
2219 {bugs_to_load => {type => ARRAYREF,
2220 default => sub {[]},
2222 data => {type => HASHREF|ARRAYREF,
2224 locks => {type => HASHREF,
2225 default => sub {{};},
2227 reload_all => {type => BOOLEAN,
2230 debug => {type => HANDLE,
2236 if (ref($param{data}) eq 'ARRAY') {
2237 for my $data (@{$param{data}}) {
2238 $data{$data->{bug_num}} = dclone($data);
2242 %data = %{dclone($param{data})};
2244 my @bugs_to_load = @{$param{bugs_to_load}};
2245 if ($param{reload_all}) {
2246 push @bugs_to_load, keys %data;
2249 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2250 @bugs_to_load = keys %temp;
2251 my %loaded_this_time;
2253 while ($bug_to_load = shift @bugs_to_load) {
2254 if (not $param{reload_all}) {
2255 next if exists $data{$bug_to_load};
2258 next if $loaded_this_time{$bug_to_load};
2261 if ($param{reload_all}) {
2262 if (exists $data{$bug_to_load}) {
2267 read_bug(bug => $bug_to_load,
2269 locks => $param{locks},
2271 die "Unable to load bug $bug_to_load";
2272 print {$param{debug}} "read bug $bug_to_load\n";
2273 $data{$data->{bug_num}} = $data;
2274 $new_locks += $lock_bug;
2275 $loaded_this_time{$data->{bug_num}} = 1;
2277 grep {not exists $data{$_}}
2278 split / /,$data->{mergedwith};
2280 return (\%data,$new_locks);
2284 sub __calculate_merge_status{
2285 my ($data_a,$data_h,$master_bug,$merge_status) = @_;
2286 my %merge_status = %{$merge_status // {}};
2288 my $bugs_to_merge = 0;
2289 for my $data (@{$data_a}) {
2290 # check to see if this bug is unmerged in the set
2291 if (not length $data->{mergedwith} or
2292 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2293 $merged_bugs{$data->{bug_num}} = 1;
2296 # the master_bug is the bug that every other bug is made to
2297 # look like. However, if merge is set, tags, fixed and found
2299 if ($data->{bug_num} == $master_bug) {
2300 for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2301 $merge_status{$_} = $data->{$_}
2304 if (defined $merge_status) {
2305 next unless $data->{bug_num} == $master_bug;
2307 $merge_status{tag} = {} if not exists $merge_status{tag};
2308 for my $tag (split /\s+/, $data->{keywords}) {
2309 $merge_status{tag}{$tag} = 1;
2311 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2312 for (qw(fixed found)) {
2313 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2316 return (\%merge_status,$bugs_to_merge);
2321 sub __calculate_merge_changes{
2322 my ($datas,$merge_status,$param) = @_;
2324 my @disallowed_changes;
2325 for my $data (@{$datas}) {
2326 # things that can be forced
2328 # * func is the function to set the new value
2330 # * key is the key of the function to set the value,
2332 # * modify_value is a function which is called to modify the new
2333 # value so that the function will accept it
2335 # * options is an ARRAYREF of options to pass to the function
2337 # * allowed is a BOOLEAN which controls whether this setting
2338 # is allowed to be different by default.
2339 my %force_functions =
2340 (forwarded => {func => \&set_forwarded,
2344 severity => {func => \&set_severity,
2348 blocks => {func => \&set_blocks,
2349 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2353 blockedby => {func => \&set_blocks,
2354 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2358 done => {func => \&set_done,
2362 owner => {func => \&owner,
2366 summary => {func => \&summary,
2370 affects => {func => \&affects,
2374 package => {func => \&set_package,
2378 keywords => {func => \&set_tag,
2380 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2383 fixed_versions => {func => \&set_fixed,
2385 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2388 found_versions => {func => \&set_found,
2390 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2394 for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2395 # if the ideal bug already has the field set properly, we
2397 if ($field eq 'keywords'){
2398 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2399 join(' ',sort keys %{$merge_status->{tag}});
2401 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2402 next if join(' ', sort @{$data->{$field}}) eq
2403 join(' ',sort keys %{$merge_status->{$field}});
2405 elsif ($field eq 'done') {
2406 # for done, we only care if the bug is done or not
2407 # done, not the value it's set to.
2408 if (defined $merge_status->{$field} and length $merge_status->{$field} and
2409 defined $data->{$field} and length $data->{$field}) {
2412 elsif ((not defined $merge_status->{$field} or not length $merge_status->{$field}) and
2413 (not defined $data->{$field} or not length $data->{$field})
2418 elsif ($merge_status->{$field} eq $data->{$field}) {
2423 bug => $data->{bug_num},
2424 orig_value => $data->{$field},
2426 (exists $force_functions{$field}{modify_value} ?
2427 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2428 $merge_status->{$field}),
2429 value => $merge_status->{$field},
2430 function => $force_functions{$field}{func},
2431 key => $force_functions{$field}{key},
2432 options => $force_functions{$field}{options},
2433 allowed => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0,
2435 $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
2436 $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
2437 if ($param->{force} or $change->{allowed}) {
2438 if ($field ne 'package' or $change->{allowed}) {
2439 push @{$changes{$data->{bug_num}}},$change;
2442 if ($param->{allow_reassign}) {
2443 if ($param->{reassign_different_sources}) {
2444 push @{$changes{$data->{bug_num}}},$change;
2447 # allow reassigning if binary_to_source returns at
2448 # least one of the same source packages
2449 my @merge_status_source =
2450 binary_to_source(package => $merge_status->{package},
2453 my @other_bug_source =
2454 binary_to_source(package => $data->{package},
2457 my %merge_status_sources;
2458 @merge_status_sources{@merge_status_source} =
2459 (1) x @merge_status_source;
2460 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2461 push @{$changes{$data->{bug_num}}},$change;
2466 push @disallowed_changes,$change;
2468 # blocks and blocked by are weird; we have to go through and
2469 # set blocks to the other half of the merged bugs
2471 return (\@disallowed_changes,\%changes);
2477 affects(bug => $ref,
2478 transcript => $transcript,
2479 ($dl > 0 ? (debug => $transcript):()),
2480 requester => $header{from},
2481 request_addr => $controlrequestaddr,
2483 affected_packages => \%affected_packages,
2484 recipients => \%recipients,
2492 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2495 This marks a bug as affecting packages which the bug is not actually
2496 in. This should only be used in cases where fixing the bug instantly
2497 resolves the problem in the other packages.
2499 By default, the packages are set to the list of packages passed.
2500 However, if you pass add => 1 or remove => 1, the list of packages
2501 passed are added or removed from the affects list, respectively.
2506 my %param = validate_with(params => \@_,
2507 spec => {bug => {type => SCALAR,
2510 # specific options here
2511 package => {type => SCALAR|ARRAYREF|UNDEF,
2514 add => {type => BOOLEAN,
2517 remove => {type => BOOLEAN,
2521 %append_action_options,
2524 if ($param{add} and $param{remove}) {
2525 croak "Asking to both add and remove affects is nonsensical";
2527 if (not defined $param{package}) {
2528 $param{package} = [];
2531 __begin_control(%param,
2532 command => 'affects'
2534 my ($debug,$transcript) =
2535 @info{qw(debug transcript)};
2536 my @data = @{$info{data}};
2537 my @bugs = @{$info{bugs}};
2539 for my $data (@data) {
2541 print {$debug} "Going to change affects\n";
2542 my @packages = splitpackages($data->{affects});
2544 @packages{@packages} = (1) x @packages;
2547 for my $package (make_list($param{package})) {
2548 next unless defined $package and length $package;
2549 if (not $packages{$package}) {
2550 $packages{$package} = 1;
2551 push @added,$package;
2555 $action = "Added indication that $data->{bug_num} affects ".
2556 english_join(\@added);
2559 elsif ($param{remove}) {
2561 for my $package (make_list($param{package})) {
2562 if ($packages{$package}) {
2563 next unless defined $package and length $package;
2564 delete $packages{$package};
2565 push @removed,$package;
2568 $action = "Removed indication that $data->{bug_num} affects " .
2569 english_join(\@removed);
2572 my %added_packages = ();
2573 my %removed_packages = %packages;
2575 for my $package (make_list($param{package})) {
2576 next unless defined $package and length $package;
2577 $packages{$package} = 1;
2578 delete $removed_packages{$package};
2579 $added_packages{$package} = 1;
2581 if (keys %removed_packages) {
2582 $action = "Removed indication that $data->{bug_num} affects ".
2583 english_join([keys %removed_packages]);
2584 $action .= "\n" if keys %added_packages;
2586 if (keys %added_packages) {
2587 $action .= "Added indication that $data->{bug_num} affects " .
2588 english_join([keys %added_packages]);
2591 if (not length $action) {
2592 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n";
2595 my $old_data = dclone($data);
2596 $data->{affects} = join(',',keys %packages);
2597 append_action_to_log(bug => $data->{bug_num},
2599 command => 'affects',
2601 old_data => $old_data,
2602 __return_append_to_log_options(
2607 if not exists $param{append_log} or $param{append_log};
2608 writebug($data->{bug_num},$data);
2609 print {$transcript} "$action\n";
2611 __end_control(%info);
2615 =head1 SUMMARY FUNCTIONS
2620 summary(bug => $ref,
2621 transcript => $transcript,
2622 ($dl > 0 ? (debug => $transcript):()),
2623 requester => $header{from},
2624 request_addr => $controlrequestaddr,
2626 affected_packages => \%affected_packages,
2627 recipients => \%recipients,
2633 print {$transcript} "Failed to mark $ref with summary foo: $@";
2636 Handles all setting of summary fields
2638 If summary is undef, unsets the summary
2640 If summary is 0, sets the summary to the first paragraph contained in
2643 If summary is a positive integer, sets the summary to the message specified.
2645 Otherwise, sets summary to the value passed.
2651 my %param = validate_with(params => \@_,
2652 spec => {bug => {type => SCALAR,
2655 # specific options here
2656 summary => {type => SCALAR|UNDEF,
2660 %append_action_options,
2663 # croak "summary must be numeric or undef" if
2664 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2666 __begin_control(%param,
2667 command => 'summary'
2669 my ($debug,$transcript) =
2670 @info{qw(debug transcript)};
2671 my @data = @{$info{data}};
2672 my @bugs = @{$info{bugs}};
2673 # figure out the log that we're going to use
2675 my $summary_msg = '';
2677 if (not defined $param{summary}) {
2679 print {$debug} "Removing summary fields\n";
2680 $action = 'Removed summary';
2682 elsif ($param{summary} =~ /^\d+$/) {
2684 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2685 if ($param{summary} == 0) {
2686 $log = $param{message};
2687 $summary_msg = @records + 1;
2690 if (($param{summary} - 1 ) > $#records) {
2691 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2693 my $record = $records[($param{summary} - 1 )];
2694 if ($record->{type} !~ /incoming-recv|recips/) {
2695 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2697 $summary_msg = $param{summary};
2698 $log = [$record->{text}];
2700 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2701 my $body = $p_o->{body};
2702 my $in_pseudoheaders = 0;
2704 # walk through body until we get non-blank lines
2705 for my $line (@{$body}) {
2706 if ($line =~ /^\s*$/) {
2707 if (length $paragraph) {
2708 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2714 $in_pseudoheaders = 0;
2717 # skip a paragraph if it looks like it's control or
2719 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2720 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2721 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2722 debug|(?:not|)forwarded|priority|
2723 (?:un|)block|limit|(?:un|)archive|
2724 reassign|retitle|affects|wrongpackage
2725 (?:un|force|)merge|user(?:category|tags?|)
2727 if (not length $paragraph) {
2728 print {$debug} "Found control/pseudo-headers and skiping them\n";
2729 $in_pseudoheaders = 1;
2733 next if $in_pseudoheaders;
2734 $paragraph .= $line ." \n";
2736 print {$debug} "Summary is going to be '$paragraph'\n";
2737 $summary = $paragraph;
2738 $summary =~ s/[\n\r]/ /g;
2739 if (not length $summary) {
2740 die "Unable to find summary message to use";
2742 # trim off a trailing spaces
2743 $summary =~ s/\ *$//;
2746 $summary = $param{summary};
2748 for my $data (@data) {
2749 print {$debug} "Going to change summary\n";
2750 if (((not defined $summary or not length $summary) and
2751 (not defined $data->{summary} or not length $data->{summary})) or
2752 $summary eq $data->{summary}) {
2753 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n";
2756 if (length $summary) {
2757 if (length $data->{summary}) {
2758 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2761 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2764 my $old_data = dclone($data);
2765 $data->{summary} = $summary;
2766 append_action_to_log(bug => $data->{bug_num},
2767 command => 'summary',
2768 old_data => $old_data,
2771 __return_append_to_log_options(
2776 if not exists $param{append_log} or $param{append_log};
2777 writebug($data->{bug_num},$data);
2778 print {$transcript} "$action\n";
2780 __end_control(%info);
2788 clone_bug(bug => $ref,
2789 transcript => $transcript,
2790 ($dl > 0 ? (debug => $transcript):()),
2791 requester => $header{from},
2792 request_addr => $controlrequestaddr,
2794 affected_packages => \%affected_packages,
2795 recipients => \%recipients,
2800 print {$transcript} "Failed to clone bug $ref bar: $@";
2803 Clones the given bug.
2805 We currently don't support cloning merged bugs, but this could be
2806 handled by internally unmerging, cloning, then remerging the bugs.
2811 my %param = validate_with(params => \@_,
2812 spec => {bug => {type => SCALAR,
2815 new_bugs => {type => ARRAYREF,
2817 new_clones => {type => HASHREF,
2821 %append_action_options,
2825 __begin_control(%param,
2828 my ($debug,$transcript) =
2829 @info{qw(debug transcript)};
2830 my @data = @{$info{data}};
2831 my @bugs = @{$info{bugs}};
2834 for my $data (@data) {
2835 if (length($data->{mergedwith})) {
2836 die "Bug is marked as being merged with others. Use an existing clone.\n";
2840 die "Not exactly one bug‽ This shouldn't happen.";
2842 my $data = $data[0];
2844 for my $newclone_id (@{$param{new_bugs}}) {
2845 my $new_bug_num = new_bug(copy => $data->{bug_num});
2846 $param{new_clones}{$newclone_id} = $new_bug_num;
2847 $clones{$newclone_id} = $new_bug_num;
2849 my @new_bugs = sort values %clones;
2851 for my $new_bug (@new_bugs) {
2852 # no collapsed ids or the higher collapsed id is not one less
2853 # than the next highest new bug
2854 if (not @collapsed_ids or
2855 $collapsed_ids[-1][1]+1 != $new_bug) {
2856 push @collapsed_ids,[$new_bug,$new_bug];
2859 $collapsed_ids[-1][1] = $new_bug;
2863 for my $ci (@collapsed_ids) {
2864 if ($ci->[0] == $ci->[1]) {
2865 push @collapsed,$ci->[0];
2868 push @collapsed,$ci->[0].'-'.$ci->[1]
2871 my $collapsed_str = english_join(\@collapsed);
2872 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2873 for my $new_bug (@new_bugs) {
2874 append_action_to_log(bug => $new_bug,
2876 __return_append_to_log_options(
2881 if not exists $param{append_log} or $param{append_log};
2883 append_action_to_log(bug => $data->{bug_num},
2885 __return_append_to_log_options(
2890 if not exists $param{append_log} or $param{append_log};
2891 writebug($data->{bug_num},$data);
2892 print {$transcript} "$action\n";
2893 __end_control(%info);
2894 # bugs that this bug is blocking are also blocked by the new clone(s)
2895 for my $bug (split ' ', $data->{blocks}) {
2896 for my $new_bug (@new_bugs) {
2897 set_blocks(bug => $new_bug,
2900 keys %common_options,
2901 keys %append_action_options),
2905 # bugs that this bug is blocked by are also blocking the new clone(s)
2906 for my $bug (split ' ', $data->{blockedby}) {
2907 for my $new_bug (@new_bugs) {
2908 set_blocks(bug => $bug,
2911 keys %common_options,
2912 keys %append_action_options),
2920 =head1 OWNER FUNCTIONS
2926 transcript => $transcript,
2927 ($dl > 0 ? (debug => $transcript):()),
2928 requester => $header{from},
2929 request_addr => $controlrequestaddr,
2931 recipients => \%recipients,
2937 print {$transcript} "Failed to mark $ref as having an owner: $@";
2940 Handles all setting of the owner field; given an owner of undef or of
2941 no length, indicates that a bug is not owned by anyone.
2946 my %param = validate_with(params => \@_,
2947 spec => {bug => {type => SCALAR,
2950 owner => {type => SCALAR|UNDEF,
2953 %append_action_options,
2957 __begin_control(%param,
2960 my ($debug,$transcript) =
2961 @info{qw(debug transcript)};
2962 my @data = @{$info{data}};
2963 my @bugs = @{$info{bugs}};
2965 for my $data (@data) {
2966 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2967 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2968 if (not defined $param{owner} or not length $param{owner}) {
2969 if (not defined $data->{owner} or not length $data->{owner}) {
2970 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n";
2974 $action = "Removed annotation that $config{bug} was owned by " .
2978 if ($data->{owner} eq $param{owner}) {
2979 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2982 if (length $data->{owner}) {
2983 $action = "Owner changed from $data->{owner} to $param{owner}.";
2986 $action = "Owner recorded as $param{owner}."
2989 my $old_data = dclone($data);
2990 $data->{owner} = $param{owner};
2991 append_action_to_log(bug => $data->{bug_num},
2994 old_data => $old_data,
2996 __return_append_to_log_options(
3001 if not exists $param{append_log} or $param{append_log};
3002 writebug($data->{bug_num},$data);
3003 print {$transcript} "$action\n";
3005 __end_control(%info);
3009 =head1 ARCHIVE FUNCTIONS
3016 bug_archive(bug => $bug_num,
3018 transcript => \$transcript,
3023 transcript("Unable to archive $bug_num\n");
3026 transcript($transcript);
3029 This routine archives a bug
3033 =item bug -- bug number
3035 =item check_archiveable -- check wether a bug is archiveable before
3036 archiving; defaults to 1
3038 =item archive_unarchived -- whether to archive bugs which have not
3039 previously been archived; defaults to 1. [Set to 0 when used from
3042 =item ignore_time -- whether to ignore time constraints when archiving
3043 a bug; defaults to 0.
3050 my %param = validate_with(params => \@_,
3051 spec => {bug => {type => SCALAR,
3054 check_archiveable => {type => BOOLEAN,
3057 archive_unarchived => {type => BOOLEAN,
3060 ignore_time => {type => BOOLEAN,
3064 %append_action_options,
3067 my %info = __begin_control(%param,
3068 command => 'archive',
3070 my ($debug,$transcript) = @info{qw(debug transcript)};
3071 my @data = @{$info{data}};
3072 my @bugs = @{$info{bugs}};
3073 my $action = "$config{bug} archived.";
3074 if ($param{check_archiveable} and
3075 not bug_archiveable(bug=>$param{bug},
3076 ignore_time => $param{ignore_time},
3078 print {$transcript} "Bug $param{bug} cannot be archived\n";
3079 die "Bug $param{bug} cannot be archived";
3081 if (not $param{archive_unarchived} and
3082 not exists $data[0]{unarchived}
3084 print {$transcript} "$param{bug} has not been archived previously\n";
3085 die "$param{bug} has not been archived previously";
3087 add_recipients(recipients => $param{recipients},
3090 transcript => $transcript,
3092 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3093 for my $bug (@bugs) {
3094 if ($param{check_archiveable}) {
3095 die "Bug $bug cannot be archived (but $param{bug} can?)"
3096 unless bug_archiveable(bug=>$bug,
3097 ignore_time => $param{ignore_time},
3101 # If we get here, we can archive/remove this bug
3102 print {$debug} "$param{bug} removing\n";
3103 for my $bug (@bugs) {
3104 #print "$param{bug} removing $bug\n" if $debug;
3105 my $dir = get_hashname($bug);
3106 # First indicate that this bug is being archived
3107 append_action_to_log(bug => $bug,
3109 command => 'archive',
3110 # we didn't actually change the data
3111 # when we archived, so we don't pass
3112 # a real new_data or old_data
3115 __return_append_to_log_options(
3120 if not exists $param{append_log} or $param{append_log};
3121 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3122 if ($config{save_old_bugs}) {
3123 mkpath("$config{spool_dir}/archive/$dir");
3124 foreach my $file (@files_to_remove) {
3125 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3126 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3127 # we need to bail out here if things have
3128 # gone horribly wrong to avoid removing a
3130 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3133 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3135 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3136 print {$debug} "deleted $bug (from $param{bug})\n";
3138 bughook_archive(@bugs);
3139 __end_control(%info);
3142 =head2 bug_unarchive
3146 bug_unarchive(bug => $bug_num,
3148 transcript => \$transcript,
3153 transcript("Unable to archive bug: $bug_num");
3155 transcript($transcript);
3157 This routine unarchives a bug
3162 my %param = validate_with(params => \@_,
3163 spec => {bug => {type => SCALAR,
3167 %append_action_options,
3171 my %info = __begin_control(%param,
3173 command=>'unarchive');
3174 my ($debug,$transcript) =
3175 @info{qw(debug transcript)};
3176 my @data = @{$info{data}};
3177 my @bugs = @{$info{bugs}};
3178 my $action = "$config{bug} unarchived.";
3179 my @files_to_remove;
3180 for my $bug (@bugs) {
3181 print {$debug} "$param{bug} removing $bug\n";
3182 my $dir = get_hashname($bug);
3183 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3184 mkpath("archive/$dir");
3185 foreach my $file (@files_to_copy) {
3186 # die'ing here sucks
3187 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3188 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3189 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3191 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3192 print {$transcript} "Unarchived $config{bug} $bug\n";
3194 unlink(@files_to_remove) or die "Unable to unlink bugs";
3195 # Indicate that this bug has been archived previously
3196 for my $bug (@bugs) {
3197 my $newdata = readbug($bug);
3198 my $old_data = dclone($newdata);
3199 if (not defined $newdata) {
3200 print {$transcript} "$config{bug} $bug disappeared!\n";
3201 die "Bug $bug disappeared!";
3203 $newdata->{unarchived} = time;
3204 append_action_to_log(bug => $bug,
3206 command => 'unarchive',
3207 new_data => $newdata,
3208 old_data => $old_data,
3209 __return_append_to_log_options(
3214 if not exists $param{append_log} or $param{append_log};
3215 writebug($bug,$newdata);
3217 __end_control(%info);
3220 =head2 append_action_to_log
3222 append_action_to_log
3224 This should probably be moved to Debbugs::Log; have to think that out
3229 sub append_action_to_log{
3230 my %param = validate_with(params => \@_,
3231 spec => {bug => {type => SCALAR,
3234 new_data => {type => HASHREF,
3237 old_data => {type => HASHREF,
3240 command => {type => SCALAR,
3243 action => {type => SCALAR,
3245 requester => {type => SCALAR,
3248 request_addr => {type => SCALAR,
3251 location => {type => SCALAR,
3254 message => {type => SCALAR|ARRAYREF,
3257 recips => {type => SCALAR|ARRAYREF,
3260 desc => {type => SCALAR,
3263 get_lock => {type => BOOLEAN,
3266 locks => {type => HASHREF,
3270 # append_action_options here
3271 # because some of these
3272 # options aren't actually
3273 # optional, even though the
3274 # original function doesn't
3278 # Fix this to use $param{location}
3279 my $log_location = buglog($param{bug});
3280 die "Unable to find .log for $param{bug}"
3281 if not defined $log_location;
3282 if ($param{get_lock}) {
3283 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3287 my $logfh = IO::File->new(">>$log_location") or
3288 die "Unable to open $log_location for appending: $!";
3289 # determine difference between old and new
3291 if (exists $param{old_data} and exists $param{new_data}) {
3292 my $old_data = dclone($param{old_data});
3293 my $new_data = dclone($param{new_data});
3294 for my $key (keys %{$old_data}) {
3295 if (not exists $Debbugs::Status::fields{$key}) {
3296 delete $old_data->{$key};
3299 next unless exists $new_data->{$key};
3300 next unless defined $new_data->{$key};
3301 if (not defined $old_data->{$key}) {
3302 delete $old_data->{$key};
3305 if (ref($new_data->{$key}) and
3306 ref($old_data->{$key}) and
3307 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3308 local $Storable::canonical = 1;
3309 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3310 delete $new_data->{$key};
3311 delete $old_data->{$key};
3314 elsif ($new_data->{$key} eq $old_data->{$key}) {
3315 delete $new_data->{$key};
3316 delete $old_data->{$key};
3319 for my $key (keys %{$new_data}) {
3320 if (not exists $Debbugs::Status::fields{$key}) {
3321 delete $new_data->{$key};
3324 next unless exists $old_data->{$key};
3325 next unless defined $old_data->{$key};
3326 if (not defined $new_data->{$key} or
3327 not exists $Debbugs::Status::fields{$key}) {
3328 delete $new_data->{$key};
3331 if (ref($new_data->{$key}) and
3332 ref($old_data->{$key}) and
3333 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3334 local $Storable::canonical = 1;
3335 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3336 delete $new_data->{$key};
3337 delete $old_data->{$key};
3340 elsif ($new_data->{$key} eq $old_data->{$key}) {
3341 delete $new_data->{$key};
3342 delete $old_data->{$key};
3345 $data_diff .= "<!-- new_data:\n";
3347 for my $key (keys %{$new_data}) {
3348 if (not exists $Debbugs::Status::fields{$key}) {
3349 warn "No such field $key";
3352 $nd{$key} = $new_data->{$key};
3353 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3355 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3356 $data_diff .= "-->\n";
3357 $data_diff .= "<!-- old_data:\n";
3359 for my $key (keys %{$old_data}) {
3360 if (not exists $Debbugs::Status::fields{$key}) {
3361 warn "No such field $key";
3364 $od{$key} = $old_data->{$key};
3365 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3367 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3368 $data_diff .= "-->\n";
3371 (exists $param{command} ?
3372 "<!-- command:".html_escape($param{command})." -->\n":""
3374 (length $param{requester} ?
3375 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3377 (length $param{request_addr} ?
3378 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3380 "<!-- time:".time()." -->\n",
3382 "<strong>".html_escape($param{action})."</strong>\n");
3383 if (length $param{requester}) {
3384 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3386 if (length $param{request_addr}) {
3387 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3389 if (length $param{desc}) {
3390 $msg .= ":<br>\n$param{desc}\n";
3395 push @records, {type => 'html',
3399 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3400 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3401 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3402 text => join('',make_list($param{message})),
3405 write_log_records(logfh=>$logfh,
3406 records => \@records,
3408 close $logfh or die "Unable to close $log_location: $!";
3409 if ($param{get_lock}) {
3410 unfilelock(exists $param{locks}?$param{locks}:());
3418 =head1 PRIVATE FUNCTIONS
3420 =head2 __handle_affected_packages
3422 __handle_affected_packages(affected_packages => {},
3430 sub __handle_affected_packages{
3431 my %param = validate_with(params => \@_,
3432 spec => {%common_options,
3433 data => {type => ARRAYREF|HASHREF
3438 for my $data (make_list($param{data})) {
3439 next unless exists $data->{package} and defined $data->{package};
3440 my @packages = split /\s*,\s*/,$data->{package};
3441 @{$param{affected_packages}}{@packages} = (1) x @packages;
3445 =head2 __handle_debug_transcript
3447 my ($debug,$transcript) = __handle_debug_transcript(%param);
3449 Returns a debug and transcript filehandle
3454 sub __handle_debug_transcript{
3455 my %param = validate_with(params => \@_,
3456 spec => {%common_options},
3459 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3460 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3461 return ($debug,$transcript);
3468 Produces a small bit of bug information to kick out to the transcript
3475 next unless defined $data and exists $data->{bug_num};
3476 $return .= "Bug #".($data->{bug_num}||'').
3477 ((defined $data->{done} and length $data->{done})?
3478 " {Done: $data->{done}}":''
3480 " [".($data->{package}||'(no package)'). "] ".
3481 ($data->{subject}||'(no subject)')."\n";
3487 =head2 __internal_request
3489 __internal_request()
3490 __internal_request($level)
3492 Returns true if the caller of the function calling __internal_request
3493 belongs to __PACKAGE__
3495 This allows us to be magical, and don't bother to print bug info if
3496 the second caller is from this package, amongst other things.
3498 An optional level is allowed, which increments the number of levels to
3499 check by the given value. [This is basically for use by internal
3500 functions like __begin_control which are always called by
3505 sub __internal_request{
3507 $l = 0 if not defined $l;
3508 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3514 sub __return_append_to_log_options{
3516 my $action = $param{action} if exists $param{action};
3517 if (not exists $param{requester}) {
3518 $param{requester} = $config{control_internal_requester};
3520 if (not exists $param{request_addr}) {
3521 $param{request_addr} = $config{control_internal_request_addr};
3523 if (not exists $param{message}) {
3524 my $date = rfc822_date();
3525 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3526 variables => {request_addr => $param{request_addr},
3527 requester => $param{requester},
3533 if (not defined $action) {
3534 carp "Undefined action!";
3535 $action = "unknown action";
3537 return (action => $action,
3538 hash_slice(%param,keys %append_action_options),
3542 =head2 __begin_control
3544 my %info = __begin_control(%param,
3546 command=>'unarchive');
3547 my ($debug,$transcript) = @info{qw(debug transcript)};
3548 my @data = @{$info{data}};
3549 my @bugs = @{$info{bugs}};
3552 Starts the process of modifying a bug; handles all of the generic
3553 things that almost every control request needs
3555 Returns a hash containing
3559 =item new_locks -- number of new locks taken out by this call
3561 =item debug -- the debug file handle
3563 =item transcript -- the transcript file handle
3565 =item data -- an arrayref containing the data of the bugs
3566 corresponding to this request
3568 =item bugs -- an arrayref containing the bug numbers of the bugs
3569 corresponding to this request
3577 sub __begin_control {
3578 my %param = validate_with(params => \@_,
3579 spec => {bug => {type => SCALAR,
3582 archived => {type => BOOLEAN,
3585 command => {type => SCALAR,
3593 my ($debug,$transcript) = __handle_debug_transcript(@_);
3594 print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n";
3595 # print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n";
3596 $lockhash = $param{locks} if exists $param{locks};
3598 my $old_die = $SIG{__DIE__};
3599 $SIG{__DIE__} = *sig_die{CODE};
3601 ($new_locks, @data) =
3602 lock_read_all_merged_bugs(bug => $param{bug},
3603 $param{archived}?(location => 'archive'):(),
3604 exists $param{locks} ? (locks => $param{locks}):(),
3606 $locks += $new_locks;
3608 die "Unable to read any bugs successfully.";
3610 if (not $param{archived}) {
3611 for my $data (@data) {
3612 if ($data->{archived}) {
3613 die "Not altering archived bugs; see unarchive.";
3617 if (not __check_limit(data => \@data,
3618 exists $param{limit}?(limit => $param{limit}):(),
3619 transcript => $transcript,
3621 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3624 __handle_affected_packages(%param,data => \@data);
3625 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3626 print {$debug} "$param{bug} read $locks locks\n";
3627 if (not @data or not defined $data[0]) {
3628 print {$transcript} "No bug found for $param{bug}\n";
3629 die "No bug found for $param{bug}";
3632 add_recipients(data => \@data,
3633 recipients => $param{recipients},
3634 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3636 (__internal_request()?(transcript => $transcript):()),
3639 print {$debug} "$param{bug} read done\n";
3640 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3641 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3642 return (data => \@data,
3644 old_die => $old_die,
3645 new_locks => $new_locks,
3647 transcript => $transcript,
3649 exists $param{locks}?(locks => $param{locks}):(),
3653 =head2 __end_control
3655 __end_control(%info);
3657 Handles tearing down from a control request
3663 if (exists $info{new_locks} and $info{new_locks} > 0) {
3664 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3665 for (1..$info{new_locks}) {
3666 unfilelock(exists $info{locks}?$info{locks}:());
3670 $SIG{__DIE__} = $info{old_die};
3671 if (exists $info{param}{affected_bugs}) {
3672 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3674 add_recipients(recipients => $info{param}{recipients},
3675 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3676 data => $info{data},
3677 debug => $info{debug},
3678 transcript => $info{transcript},
3680 __handle_affected_packages(%{$info{param}},data=>$info{data});
3684 =head2 __check_limit
3686 __check_limit(data => \@data, limit => $param{limit});
3689 Checks to make sure that bugs match any limits; each entry of @data
3690 much satisfy the limit.
3692 Returns true if there are no entries in data, or there are no keys in
3693 limit; returns false (0) if there are any entries which do not match.
3695 The limit hashref elements can contain an arrayref of scalars to
3696 match; regexes are also acccepted. At least one of the entries in each
3697 element needs to match the corresponding field in all data for the
3704 my %param = validate_with(params => \@_,
3705 spec => {data => {type => ARRAYREF|SCALAR,
3707 limit => {type => HASHREF|UNDEF,
3709 transcript => {type => SCALARREF|HANDLE,
3714 my @data = make_list($param{data});
3716 not defined $param{limit} or
3717 not keys %{$param{limit}}) {
3720 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3721 my $going_to_fail = 0;
3722 for my $data (@data) {
3723 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3724 status => dclone($data),
3726 for my $field (keys %{$param{limit}}) {
3727 next unless exists $param{limit}{$field};
3729 my @data_fields = make_list($data->{$field});
3730 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3731 if (not ref $limit) {
3732 for my $data_field (@data_fields) {
3733 if ($data_field eq $limit) {
3739 elsif (ref($limit) eq 'Regexp') {
3740 for my $data_field (@data_fields) {
3741 if ($data_field =~ $limit) {
3748 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3753 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3754 "' does not match at least one of ".
3755 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3759 return $going_to_fail?0:1;
3767 We override die to specially handle unlocking files in the cases where
3768 we are called via eval. [If we're not called via eval, it doesn't
3774 if ($^S) { # in eval
3776 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3783 # =head2 __message_body_template
3785 # message_body_template('mail/ack',{ref=>'foo'});
3787 # Creates a message body using a template
3791 sub __message_body_template{
3792 my ($template,$extra_var) = @_;
3794 my $hole_var = {'&bugurl' =>
3796 'http://'.$config{cgi_domain}.'/'.
3797 Debbugs::CGI::bug_url($_[0]);
3801 my $body = fill_in_template(template => $template,
3802 variables => {config => \%config,
3805 hole_var => $hole_var,
3807 return fill_in_template(template => 'mail/message_body',
3808 variables => {config => \%config,
3812 hole_var => $hole_var,
3816 sub __all_undef_or_equal {
3818 return 1 if @values == 1 or @values == 0;
3819 my $not_def = grep {not defined $_} @values;
3820 if ($not_def == @values) {
3823 if ($not_def > 0 and $not_def != @values) {
3826 my $first_val = shift @values;
3827 for my $val (@values) {
3828 if ($first_val ne $val) {