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("$config{spool_dir}/db-h/$hash/$data->{bug_num}.report",'r') or
955 die "Unable to open original report $config{spool_dir}/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 @bugs_to_change = keys %{$changes};
2092 for my $change_bug (@bugs_to_change) {
2093 next unless exists $changes->{$change_bug};
2094 $bug_changed{$change_bug}++;
2095 print {$transcript} __bug_info($data{$change_bug}) if
2096 $param{show_bug_info} and not __internal_request(1);
2097 $bug_info_shown{$change_bug} = 1;
2098 __allow_relocking($param{locks},[keys %data]);
2099 for my $change (@{$changes->{$change_bug}}) {
2100 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2101 my %target_blockedby;
2102 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2103 my %unhandled_targets = %target_blockedby;
2104 my @blocks_to_remove;
2105 for my $key (split / /,$change->{orig_value}) {
2106 delete $unhandled_targets{$key};
2107 next if exists $target_blockedby{$key};
2108 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2109 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2112 keys %common_options,
2113 keys %append_action_options),
2116 for my $key (keys %unhandled_targets) {
2117 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2118 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2121 keys %common_options,
2122 keys %append_action_options),
2127 $change->{function}->(bug => $change->{bug},
2128 $change->{key}, $change->{func_value},
2129 exists $change->{options}?@{$change->{options}}:(),
2131 keys %common_options,
2132 keys %append_action_options),
2136 __disallow_relocking($param{locks});
2137 my ($data,$n_locks) =
2138 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2140 locks => $param{locks},
2144 $new_locks += $n_locks;
2147 @data = values %data;
2148 ($merge_status,$bugs_to_merge) =
2149 __calculate_merge_status(\@data,\%data,$param{bug},$merge_status);
2150 ($disallowed_changes,$changes) =
2151 __calculate_merge_changes(\@data,$merge_status,\%param);
2152 $attempts = max(values %bug_changed);
2155 if ($param{show_bug_info} and not __internal_request(1)) {
2156 for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2157 next if $bug_info_shown{$data->{bug_num}};
2158 print {$transcript} __bug_info($data);
2161 if (keys %{$changes} or @{$disallowed_changes}) {
2162 print {$transcript} "After four attempts, the following changes were unable to be made:\n";
2163 for (1..$new_locks) {
2164 unfilelock($param{locks});
2167 __end_control(%info);
2168 for my $change (values %{$changes}, @{$disallowed_changes}) {
2169 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2171 die "Unable to modify bugs so they could be merged";
2175 # finally, we can merge the bugs
2176 my $action = "Merged ".join(' ',sort keys %merged_bugs);
2177 for my $data (@data) {
2178 my $old_data = dclone($data);
2179 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2181 append_action_to_log(bug => $data->{bug_num},
2184 old_data => $old_data,
2186 __return_append_to_log_options(%param,
2190 if not exists $param{append_log} or $param{append_log};
2191 writebug($data->{bug_num},$data);
2193 print {$transcript} "$action\n";
2194 # unlock the extra locks that we got earlier
2195 for (1..$new_locks) {
2196 unfilelock($param{locks});
2199 __end_control(%info);
2202 sub __allow_relocking{
2203 my ($locks,$bugs) = @_;
2205 my @locks = (@{$bugs},'merge');
2206 for my $lock (@locks) {
2207 my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}};
2208 next unless @lockfiles;
2209 $locks->{relockable}{$lockfiles[0]} = 0;
2213 sub __disallow_relocking{
2215 delete $locks->{relockable};
2218 sub __lock_and_load_merged_bugs{
2220 validate_with(params => \@_,
2222 {bugs_to_load => {type => ARRAYREF,
2223 default => sub {[]},
2225 data => {type => HASHREF|ARRAYREF,
2227 locks => {type => HASHREF,
2228 default => sub {{};},
2230 reload_all => {type => BOOLEAN,
2233 debug => {type => HANDLE,
2239 if (ref($param{data}) eq 'ARRAY') {
2240 for my $data (@{$param{data}}) {
2241 $data{$data->{bug_num}} = dclone($data);
2245 %data = %{dclone($param{data})};
2247 my @bugs_to_load = @{$param{bugs_to_load}};
2248 if ($param{reload_all}) {
2249 push @bugs_to_load, keys %data;
2252 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2253 @bugs_to_load = keys %temp;
2254 my %loaded_this_time;
2256 while ($bug_to_load = shift @bugs_to_load) {
2257 if (not $param{reload_all}) {
2258 next if exists $data{$bug_to_load};
2261 next if $loaded_this_time{$bug_to_load};
2264 if ($param{reload_all}) {
2265 if (exists $data{$bug_to_load}) {
2270 read_bug(bug => $bug_to_load,
2272 locks => $param{locks},
2274 die "Unable to load bug $bug_to_load";
2275 print {$param{debug}} "read bug $bug_to_load\n";
2276 $data{$data->{bug_num}} = $data;
2277 $new_locks += $lock_bug;
2278 $loaded_this_time{$data->{bug_num}} = 1;
2280 grep {not exists $data{$_}}
2281 split / /,$data->{mergedwith};
2283 return (\%data,$new_locks);
2287 sub __calculate_merge_status{
2288 my ($data_a,$data_h,$master_bug,$merge_status) = @_;
2289 my %merge_status = %{$merge_status // {}};
2291 my $bugs_to_merge = 0;
2292 for my $data (@{$data_a}) {
2293 # check to see if this bug is unmerged in the set
2294 if (not length $data->{mergedwith} or
2295 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2296 $merged_bugs{$data->{bug_num}} = 1;
2299 # the master_bug is the bug that every other bug is made to
2300 # look like. However, if merge is set, tags, fixed and found
2302 if ($data->{bug_num} == $master_bug) {
2303 for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2304 $merge_status{$_} = $data->{$_}
2307 if (defined $merge_status) {
2308 next unless $data->{bug_num} == $master_bug;
2310 $merge_status{tag} = {} if not exists $merge_status{tag};
2311 for my $tag (split /\s+/, $data->{keywords}) {
2312 $merge_status{tag}{$tag} = 1;
2314 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2315 for (qw(fixed found)) {
2316 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2319 return (\%merge_status,$bugs_to_merge);
2324 sub __calculate_merge_changes{
2325 my ($datas,$merge_status,$param) = @_;
2327 my @disallowed_changes;
2328 for my $data (@{$datas}) {
2329 # things that can be forced
2331 # * func is the function to set the new value
2333 # * key is the key of the function to set the value,
2335 # * modify_value is a function which is called to modify the new
2336 # value so that the function will accept it
2338 # * options is an ARRAYREF of options to pass to the function
2340 # * allowed is a BOOLEAN which controls whether this setting
2341 # is allowed to be different by default.
2342 my %force_functions =
2343 (forwarded => {func => \&set_forwarded,
2347 severity => {func => \&set_severity,
2351 blocks => {func => \&set_blocks,
2352 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2356 blockedby => {func => \&set_blocks,
2357 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2361 done => {func => \&set_done,
2365 owner => {func => \&owner,
2369 summary => {func => \&summary,
2373 affects => {func => \&affects,
2377 package => {func => \&set_package,
2381 keywords => {func => \&set_tag,
2383 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2386 fixed_versions => {func => \&set_fixed,
2388 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2391 found_versions => {func => \&set_found,
2393 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2397 for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2398 # if the ideal bug already has the field set properly, we
2400 if ($field eq 'keywords'){
2401 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2402 join(' ',sort keys %{$merge_status->{tag}});
2404 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2405 next if join(' ', sort @{$data->{$field}}) eq
2406 join(' ',sort keys %{$merge_status->{$field}});
2408 elsif ($field eq 'done') {
2409 # for done, we only care if the bug is done or not
2410 # done, not the value it's set to.
2411 if (defined $merge_status->{$field} and length $merge_status->{$field} and
2412 defined $data->{$field} and length $data->{$field}) {
2415 elsif ((not defined $merge_status->{$field} or not length $merge_status->{$field}) and
2416 (not defined $data->{$field} or not length $data->{$field})
2421 elsif ($merge_status->{$field} eq $data->{$field}) {
2426 bug => $data->{bug_num},
2427 orig_value => $data->{$field},
2429 (exists $force_functions{$field}{modify_value} ?
2430 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2431 $merge_status->{$field}),
2432 value => $merge_status->{$field},
2433 function => $force_functions{$field}{func},
2434 key => $force_functions{$field}{key},
2435 options => $force_functions{$field}{options},
2436 allowed => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0,
2438 $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
2439 $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
2440 if ($param->{force} or $change->{allowed}) {
2441 if ($field ne 'package' or $change->{allowed}) {
2442 push @{$changes{$data->{bug_num}}},$change;
2445 if ($param->{allow_reassign}) {
2446 if ($param->{reassign_different_sources}) {
2447 push @{$changes{$data->{bug_num}}},$change;
2450 # allow reassigning if binary_to_source returns at
2451 # least one of the same source packages
2452 my @merge_status_source =
2453 binary_to_source(package => $merge_status->{package},
2456 my @other_bug_source =
2457 binary_to_source(package => $data->{package},
2460 my %merge_status_sources;
2461 @merge_status_sources{@merge_status_source} =
2462 (1) x @merge_status_source;
2463 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2464 push @{$changes{$data->{bug_num}}},$change;
2469 push @disallowed_changes,$change;
2471 # blocks and blocked by are weird; we have to go through and
2472 # set blocks to the other half of the merged bugs
2474 return (\@disallowed_changes,\%changes);
2480 affects(bug => $ref,
2481 transcript => $transcript,
2482 ($dl > 0 ? (debug => $transcript):()),
2483 requester => $header{from},
2484 request_addr => $controlrequestaddr,
2486 affected_packages => \%affected_packages,
2487 recipients => \%recipients,
2495 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2498 This marks a bug as affecting packages which the bug is not actually
2499 in. This should only be used in cases where fixing the bug instantly
2500 resolves the problem in the other packages.
2502 By default, the packages are set to the list of packages passed.
2503 However, if you pass add => 1 or remove => 1, the list of packages
2504 passed are added or removed from the affects list, respectively.
2509 my %param = validate_with(params => \@_,
2510 spec => {bug => {type => SCALAR,
2513 # specific options here
2514 package => {type => SCALAR|ARRAYREF|UNDEF,
2517 add => {type => BOOLEAN,
2520 remove => {type => BOOLEAN,
2524 %append_action_options,
2527 if ($param{add} and $param{remove}) {
2528 croak "Asking to both add and remove affects is nonsensical";
2530 if (not defined $param{package}) {
2531 $param{package} = [];
2534 __begin_control(%param,
2535 command => 'affects'
2537 my ($debug,$transcript) =
2538 @info{qw(debug transcript)};
2539 my @data = @{$info{data}};
2540 my @bugs = @{$info{bugs}};
2542 for my $data (@data) {
2544 print {$debug} "Going to change affects\n";
2545 my @packages = splitpackages($data->{affects});
2547 @packages{@packages} = (1) x @packages;
2550 for my $package (make_list($param{package})) {
2551 next unless defined $package and length $package;
2552 if (not $packages{$package}) {
2553 $packages{$package} = 1;
2554 push @added,$package;
2558 $action = "Added indication that $data->{bug_num} affects ".
2559 english_join(\@added);
2562 elsif ($param{remove}) {
2564 for my $package (make_list($param{package})) {
2565 if ($packages{$package}) {
2566 next unless defined $package and length $package;
2567 delete $packages{$package};
2568 push @removed,$package;
2571 $action = "Removed indication that $data->{bug_num} affects " .
2572 english_join(\@removed);
2575 my %added_packages = ();
2576 my %removed_packages = %packages;
2578 for my $package (make_list($param{package})) {
2579 next unless defined $package and length $package;
2580 $packages{$package} = 1;
2581 delete $removed_packages{$package};
2582 $added_packages{$package} = 1;
2584 if (keys %removed_packages) {
2585 $action = "Removed indication that $data->{bug_num} affects ".
2586 english_join([keys %removed_packages]);
2587 $action .= "\n" if keys %added_packages;
2589 if (keys %added_packages) {
2590 $action .= "Added indication that $data->{bug_num} affects " .
2591 english_join([keys %added_packages]);
2594 if (not length $action) {
2595 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n";
2598 my $old_data = dclone($data);
2599 $data->{affects} = join(',',keys %packages);
2600 append_action_to_log(bug => $data->{bug_num},
2602 command => 'affects',
2604 old_data => $old_data,
2605 __return_append_to_log_options(
2610 if not exists $param{append_log} or $param{append_log};
2611 writebug($data->{bug_num},$data);
2612 print {$transcript} "$action\n";
2614 __end_control(%info);
2618 =head1 SUMMARY FUNCTIONS
2623 summary(bug => $ref,
2624 transcript => $transcript,
2625 ($dl > 0 ? (debug => $transcript):()),
2626 requester => $header{from},
2627 request_addr => $controlrequestaddr,
2629 affected_packages => \%affected_packages,
2630 recipients => \%recipients,
2636 print {$transcript} "Failed to mark $ref with summary foo: $@";
2639 Handles all setting of summary fields
2641 If summary is undef, unsets the summary
2643 If summary is 0, sets the summary to the first paragraph contained in
2646 If summary is a positive integer, sets the summary to the message specified.
2648 Otherwise, sets summary to the value passed.
2654 my %param = validate_with(params => \@_,
2655 spec => {bug => {type => SCALAR,
2658 # specific options here
2659 summary => {type => SCALAR|UNDEF,
2663 %append_action_options,
2666 # croak "summary must be numeric or undef" if
2667 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2669 __begin_control(%param,
2670 command => 'summary'
2672 my ($debug,$transcript) =
2673 @info{qw(debug transcript)};
2674 my @data = @{$info{data}};
2675 my @bugs = @{$info{bugs}};
2676 # figure out the log that we're going to use
2678 my $summary_msg = '';
2680 if (not defined $param{summary}) {
2682 print {$debug} "Removing summary fields\n";
2683 $action = 'Removed summary';
2685 elsif ($param{summary} =~ /^\d+$/) {
2687 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2688 if ($param{summary} == 0) {
2689 $log = $param{message};
2690 $summary_msg = @records + 1;
2693 if (($param{summary} - 1 ) > $#records) {
2694 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2696 my $record = $records[($param{summary} - 1 )];
2697 if ($record->{type} !~ /incoming-recv|recips/) {
2698 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2700 $summary_msg = $param{summary};
2701 $log = [$record->{text}];
2703 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2704 my $body = $p_o->{body};
2705 my $in_pseudoheaders = 0;
2707 # walk through body until we get non-blank lines
2708 for my $line (@{$body}) {
2709 if ($line =~ /^\s*$/) {
2710 if (length $paragraph) {
2711 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2717 $in_pseudoheaders = 0;
2720 # skip a paragraph if it looks like it's control or
2722 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2723 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2724 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2725 debug|(?:not|)forwarded|priority|
2726 (?:un|)block|limit|(?:un|)archive|
2727 reassign|retitle|affects|wrongpackage
2728 (?:un|force|)merge|user(?:category|tags?|)
2730 if (not length $paragraph) {
2731 print {$debug} "Found control/pseudo-headers and skiping them\n";
2732 $in_pseudoheaders = 1;
2736 next if $in_pseudoheaders;
2737 $paragraph .= $line ." \n";
2739 print {$debug} "Summary is going to be '$paragraph'\n";
2740 $summary = $paragraph;
2741 $summary =~ s/[\n\r]/ /g;
2742 if (not length $summary) {
2743 die "Unable to find summary message to use";
2745 # trim off a trailing spaces
2746 $summary =~ s/\ *$//;
2749 $summary = $param{summary};
2751 for my $data (@data) {
2752 print {$debug} "Going to change summary\n";
2753 if (((not defined $summary or not length $summary) and
2754 (not defined $data->{summary} or not length $data->{summary})) or
2755 $summary eq $data->{summary}) {
2756 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n";
2759 if (length $summary) {
2760 if (length $data->{summary}) {
2761 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2764 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2767 my $old_data = dclone($data);
2768 $data->{summary} = $summary;
2769 append_action_to_log(bug => $data->{bug_num},
2770 command => 'summary',
2771 old_data => $old_data,
2774 __return_append_to_log_options(
2779 if not exists $param{append_log} or $param{append_log};
2780 writebug($data->{bug_num},$data);
2781 print {$transcript} "$action\n";
2783 __end_control(%info);
2791 clone_bug(bug => $ref,
2792 transcript => $transcript,
2793 ($dl > 0 ? (debug => $transcript):()),
2794 requester => $header{from},
2795 request_addr => $controlrequestaddr,
2797 affected_packages => \%affected_packages,
2798 recipients => \%recipients,
2803 print {$transcript} "Failed to clone bug $ref bar: $@";
2806 Clones the given bug.
2808 We currently don't support cloning merged bugs, but this could be
2809 handled by internally unmerging, cloning, then remerging the bugs.
2814 my %param = validate_with(params => \@_,
2815 spec => {bug => {type => SCALAR,
2818 new_bugs => {type => ARRAYREF,
2820 new_clones => {type => HASHREF,
2824 %append_action_options,
2828 __begin_control(%param,
2831 my ($debug,$transcript) =
2832 @info{qw(debug transcript)};
2833 my @data = @{$info{data}};
2834 my @bugs = @{$info{bugs}};
2837 for my $data (@data) {
2838 if (length($data->{mergedwith})) {
2839 die "Bug is marked as being merged with others. Use an existing clone.\n";
2843 die "Not exactly one bug‽ This shouldn't happen.";
2845 my $data = $data[0];
2847 for my $newclone_id (@{$param{new_bugs}}) {
2848 my $new_bug_num = new_bug(copy => $data->{bug_num});
2849 $param{new_clones}{$newclone_id} = $new_bug_num;
2850 $clones{$newclone_id} = $new_bug_num;
2852 my @new_bugs = sort values %clones;
2854 for my $new_bug (@new_bugs) {
2855 # no collapsed ids or the higher collapsed id is not one less
2856 # than the next highest new bug
2857 if (not @collapsed_ids or
2858 $collapsed_ids[-1][1]+1 != $new_bug) {
2859 push @collapsed_ids,[$new_bug,$new_bug];
2862 $collapsed_ids[-1][1] = $new_bug;
2866 for my $ci (@collapsed_ids) {
2867 if ($ci->[0] == $ci->[1]) {
2868 push @collapsed,$ci->[0];
2871 push @collapsed,$ci->[0].'-'.$ci->[1]
2874 my $collapsed_str = english_join(\@collapsed);
2875 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2876 for my $new_bug (@new_bugs) {
2877 append_action_to_log(bug => $new_bug,
2879 __return_append_to_log_options(
2884 if not exists $param{append_log} or $param{append_log};
2886 append_action_to_log(bug => $data->{bug_num},
2888 __return_append_to_log_options(
2893 if not exists $param{append_log} or $param{append_log};
2894 writebug($data->{bug_num},$data);
2895 print {$transcript} "$action\n";
2896 __end_control(%info);
2897 # bugs that this bug is blocking are also blocked by the new clone(s)
2898 for my $bug (split ' ', $data->{blocks}) {
2899 for my $new_bug (@new_bugs) {
2900 set_blocks(bug => $new_bug,
2903 keys %common_options,
2904 keys %append_action_options),
2908 # bugs that this bug is blocked by are also blocking the new clone(s)
2909 for my $bug (split ' ', $data->{blockedby}) {
2910 for my $new_bug (@new_bugs) {
2911 set_blocks(bug => $bug,
2914 keys %common_options,
2915 keys %append_action_options),
2923 =head1 OWNER FUNCTIONS
2929 transcript => $transcript,
2930 ($dl > 0 ? (debug => $transcript):()),
2931 requester => $header{from},
2932 request_addr => $controlrequestaddr,
2934 recipients => \%recipients,
2940 print {$transcript} "Failed to mark $ref as having an owner: $@";
2943 Handles all setting of the owner field; given an owner of undef or of
2944 no length, indicates that a bug is not owned by anyone.
2949 my %param = validate_with(params => \@_,
2950 spec => {bug => {type => SCALAR,
2953 owner => {type => SCALAR|UNDEF,
2956 %append_action_options,
2960 __begin_control(%param,
2963 my ($debug,$transcript) =
2964 @info{qw(debug transcript)};
2965 my @data = @{$info{data}};
2966 my @bugs = @{$info{bugs}};
2968 for my $data (@data) {
2969 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2970 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2971 if (not defined $param{owner} or not length $param{owner}) {
2972 if (not defined $data->{owner} or not length $data->{owner}) {
2973 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n";
2977 $action = "Removed annotation that $config{bug} was owned by " .
2981 if ($data->{owner} eq $param{owner}) {
2982 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2985 if (length $data->{owner}) {
2986 $action = "Owner changed from $data->{owner} to $param{owner}.";
2989 $action = "Owner recorded as $param{owner}."
2992 my $old_data = dclone($data);
2993 $data->{owner} = $param{owner};
2994 append_action_to_log(bug => $data->{bug_num},
2997 old_data => $old_data,
2999 __return_append_to_log_options(
3004 if not exists $param{append_log} or $param{append_log};
3005 writebug($data->{bug_num},$data);
3006 print {$transcript} "$action\n";
3008 __end_control(%info);
3012 =head1 ARCHIVE FUNCTIONS
3019 bug_archive(bug => $bug_num,
3021 transcript => \$transcript,
3026 transcript("Unable to archive $bug_num\n");
3029 transcript($transcript);
3032 This routine archives a bug
3036 =item bug -- bug number
3038 =item check_archiveable -- check wether a bug is archiveable before
3039 archiving; defaults to 1
3041 =item archive_unarchived -- whether to archive bugs which have not
3042 previously been archived; defaults to 1. [Set to 0 when used from
3045 =item ignore_time -- whether to ignore time constraints when archiving
3046 a bug; defaults to 0.
3053 my %param = validate_with(params => \@_,
3054 spec => {bug => {type => SCALAR,
3057 check_archiveable => {type => BOOLEAN,
3060 archive_unarchived => {type => BOOLEAN,
3063 ignore_time => {type => BOOLEAN,
3067 %append_action_options,
3070 my %info = __begin_control(%param,
3071 command => 'archive',
3073 my ($debug,$transcript) = @info{qw(debug transcript)};
3074 my @data = @{$info{data}};
3075 my @bugs = @{$info{bugs}};
3076 my $action = "$config{bug} archived.";
3077 if ($param{check_archiveable} and
3078 not bug_archiveable(bug=>$param{bug},
3079 ignore_time => $param{ignore_time},
3081 print {$transcript} "Bug $param{bug} cannot be archived\n";
3082 die "Bug $param{bug} cannot be archived";
3084 if (not $param{archive_unarchived} and
3085 not exists $data[0]{unarchived}
3087 print {$transcript} "$param{bug} has not been archived previously\n";
3088 die "$param{bug} has not been archived previously";
3090 add_recipients(recipients => $param{recipients},
3093 transcript => $transcript,
3095 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3096 for my $bug (@bugs) {
3097 if ($param{check_archiveable}) {
3098 die "Bug $bug cannot be archived (but $param{bug} can?)"
3099 unless bug_archiveable(bug=>$bug,
3100 ignore_time => $param{ignore_time},
3104 # If we get here, we can archive/remove this bug
3105 print {$debug} "$param{bug} removing\n";
3106 for my $bug (@bugs) {
3107 #print "$param{bug} removing $bug\n" if $debug;
3108 my $dir = get_hashname($bug);
3109 # First indicate that this bug is being archived
3110 append_action_to_log(bug => $bug,
3112 command => 'archive',
3113 # we didn't actually change the data
3114 # when we archived, so we don't pass
3115 # a real new_data or old_data
3118 __return_append_to_log_options(
3123 if not exists $param{append_log} or $param{append_log};
3124 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3125 if ($config{save_old_bugs}) {
3126 mkpath("$config{spool_dir}/archive/$dir");
3127 foreach my $file (@files_to_remove) {
3128 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3129 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3130 # we need to bail out here if things have
3131 # gone horribly wrong to avoid removing a
3133 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3136 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3138 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3139 print {$debug} "deleted $bug (from $param{bug})\n";
3141 bughook_archive(@bugs);
3142 __end_control(%info);
3145 =head2 bug_unarchive
3149 bug_unarchive(bug => $bug_num,
3151 transcript => \$transcript,
3156 transcript("Unable to archive bug: $bug_num");
3158 transcript($transcript);
3160 This routine unarchives a bug
3165 my %param = validate_with(params => \@_,
3166 spec => {bug => {type => SCALAR,
3170 %append_action_options,
3174 my %info = __begin_control(%param,
3176 command=>'unarchive');
3177 my ($debug,$transcript) =
3178 @info{qw(debug transcript)};
3179 my @data = @{$info{data}};
3180 my @bugs = @{$info{bugs}};
3181 my $action = "$config{bug} unarchived.";
3182 my @files_to_remove;
3183 for my $bug (@bugs) {
3184 print {$debug} "$param{bug} removing $bug\n";
3185 my $dir = get_hashname($bug);
3186 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3187 mkpath("archive/$dir");
3188 foreach my $file (@files_to_copy) {
3189 # die'ing here sucks
3190 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3191 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3192 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3194 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3195 print {$transcript} "Unarchived $config{bug} $bug\n";
3197 unlink(@files_to_remove) or die "Unable to unlink bugs";
3198 # Indicate that this bug has been archived previously
3199 for my $bug (@bugs) {
3200 my $newdata = readbug($bug);
3201 my $old_data = dclone($newdata);
3202 if (not defined $newdata) {
3203 print {$transcript} "$config{bug} $bug disappeared!\n";
3204 die "Bug $bug disappeared!";
3206 $newdata->{unarchived} = time;
3207 append_action_to_log(bug => $bug,
3209 command => 'unarchive',
3210 new_data => $newdata,
3211 old_data => $old_data,
3212 __return_append_to_log_options(
3217 if not exists $param{append_log} or $param{append_log};
3218 writebug($bug,$newdata);
3220 __end_control(%info);
3223 =head2 append_action_to_log
3225 append_action_to_log
3227 This should probably be moved to Debbugs::Log; have to think that out
3232 sub append_action_to_log{
3233 my %param = validate_with(params => \@_,
3234 spec => {bug => {type => SCALAR,
3237 new_data => {type => HASHREF,
3240 old_data => {type => HASHREF,
3243 command => {type => SCALAR,
3246 action => {type => SCALAR,
3248 requester => {type => SCALAR,
3251 request_addr => {type => SCALAR,
3254 location => {type => SCALAR,
3257 message => {type => SCALAR|ARRAYREF,
3260 recips => {type => SCALAR|ARRAYREF,
3263 desc => {type => SCALAR,
3266 get_lock => {type => BOOLEAN,
3269 locks => {type => HASHREF,
3273 # append_action_options here
3274 # because some of these
3275 # options aren't actually
3276 # optional, even though the
3277 # original function doesn't
3281 # Fix this to use $param{location}
3282 my $log_location = buglog($param{bug});
3283 die "Unable to find .log for $param{bug}"
3284 if not defined $log_location;
3285 if ($param{get_lock}) {
3286 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3290 my $logfh = IO::File->new(">>$log_location") or
3291 die "Unable to open $log_location for appending: $!";
3292 # determine difference between old and new
3294 if (exists $param{old_data} and exists $param{new_data}) {
3295 my $old_data = dclone($param{old_data});
3296 my $new_data = dclone($param{new_data});
3297 for my $key (keys %{$old_data}) {
3298 if (not exists $Debbugs::Status::fields{$key}) {
3299 delete $old_data->{$key};
3302 next unless exists $new_data->{$key};
3303 next unless defined $new_data->{$key};
3304 if (not defined $old_data->{$key}) {
3305 delete $old_data->{$key};
3308 if (ref($new_data->{$key}) and
3309 ref($old_data->{$key}) and
3310 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3311 local $Storable::canonical = 1;
3312 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3313 delete $new_data->{$key};
3314 delete $old_data->{$key};
3317 elsif ($new_data->{$key} eq $old_data->{$key}) {
3318 delete $new_data->{$key};
3319 delete $old_data->{$key};
3322 for my $key (keys %{$new_data}) {
3323 if (not exists $Debbugs::Status::fields{$key}) {
3324 delete $new_data->{$key};
3327 next unless exists $old_data->{$key};
3328 next unless defined $old_data->{$key};
3329 if (not defined $new_data->{$key} or
3330 not exists $Debbugs::Status::fields{$key}) {
3331 delete $new_data->{$key};
3334 if (ref($new_data->{$key}) and
3335 ref($old_data->{$key}) and
3336 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3337 local $Storable::canonical = 1;
3338 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3339 delete $new_data->{$key};
3340 delete $old_data->{$key};
3343 elsif ($new_data->{$key} eq $old_data->{$key}) {
3344 delete $new_data->{$key};
3345 delete $old_data->{$key};
3348 $data_diff .= "<!-- new_data:\n";
3350 for my $key (keys %{$new_data}) {
3351 if (not exists $Debbugs::Status::fields{$key}) {
3352 warn "No such field $key";
3355 $nd{$key} = $new_data->{$key};
3356 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3358 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3359 $data_diff .= "-->\n";
3360 $data_diff .= "<!-- old_data:\n";
3362 for my $key (keys %{$old_data}) {
3363 if (not exists $Debbugs::Status::fields{$key}) {
3364 warn "No such field $key";
3367 $od{$key} = $old_data->{$key};
3368 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3370 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3371 $data_diff .= "-->\n";
3374 (exists $param{command} ?
3375 "<!-- command:".html_escape($param{command})." -->\n":""
3377 (length $param{requester} ?
3378 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3380 (length $param{request_addr} ?
3381 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3383 "<!-- time:".time()." -->\n",
3385 "<strong>".html_escape($param{action})."</strong>\n");
3386 if (length $param{requester}) {
3387 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3389 if (length $param{request_addr}) {
3390 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3392 if (length $param{desc}) {
3393 $msg .= ":<br>\n$param{desc}\n";
3398 push @records, {type => 'html',
3402 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3403 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3404 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3405 text => join('',make_list($param{message})),
3408 write_log_records(logfh=>$logfh,
3409 records => \@records,
3411 close $logfh or die "Unable to close $log_location: $!";
3412 if ($param{get_lock}) {
3413 unfilelock(exists $param{locks}?$param{locks}:());
3421 =head1 PRIVATE FUNCTIONS
3423 =head2 __handle_affected_packages
3425 __handle_affected_packages(affected_packages => {},
3433 sub __handle_affected_packages{
3434 my %param = validate_with(params => \@_,
3435 spec => {%common_options,
3436 data => {type => ARRAYREF|HASHREF
3441 for my $data (make_list($param{data})) {
3442 next unless exists $data->{package} and defined $data->{package};
3443 my @packages = split /\s*,\s*/,$data->{package};
3444 @{$param{affected_packages}}{@packages} = (1) x @packages;
3448 =head2 __handle_debug_transcript
3450 my ($debug,$transcript) = __handle_debug_transcript(%param);
3452 Returns a debug and transcript filehandle
3457 sub __handle_debug_transcript{
3458 my %param = validate_with(params => \@_,
3459 spec => {%common_options},
3462 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3463 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3464 return ($debug,$transcript);
3471 Produces a small bit of bug information to kick out to the transcript
3478 next unless defined $data and exists $data->{bug_num};
3479 $return .= "Bug #".($data->{bug_num}||'').
3480 ((defined $data->{done} and length $data->{done})?
3481 " {Done: $data->{done}}":''
3483 " [".($data->{package}||'(no package)'). "] ".
3484 ($data->{subject}||'(no subject)')."\n";
3490 =head2 __internal_request
3492 __internal_request()
3493 __internal_request($level)
3495 Returns true if the caller of the function calling __internal_request
3496 belongs to __PACKAGE__
3498 This allows us to be magical, and don't bother to print bug info if
3499 the second caller is from this package, amongst other things.
3501 An optional level is allowed, which increments the number of levels to
3502 check by the given value. [This is basically for use by internal
3503 functions like __begin_control which are always called by
3508 sub __internal_request{
3510 $l = 0 if not defined $l;
3511 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3517 sub __return_append_to_log_options{
3519 my $action = $param{action} if exists $param{action};
3520 if (not exists $param{requester}) {
3521 $param{requester} = $config{control_internal_requester};
3523 if (not exists $param{request_addr}) {
3524 $param{request_addr} = $config{control_internal_request_addr};
3526 if (not exists $param{message}) {
3527 my $date = rfc822_date();
3528 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3529 variables => {request_addr => $param{request_addr},
3530 requester => $param{requester},
3536 if (not defined $action) {
3537 carp "Undefined action!";
3538 $action = "unknown action";
3540 return (action => $action,
3541 hash_slice(%param,keys %append_action_options),
3545 =head2 __begin_control
3547 my %info = __begin_control(%param,
3549 command=>'unarchive');
3550 my ($debug,$transcript) = @info{qw(debug transcript)};
3551 my @data = @{$info{data}};
3552 my @bugs = @{$info{bugs}};
3555 Starts the process of modifying a bug; handles all of the generic
3556 things that almost every control request needs
3558 Returns a hash containing
3562 =item new_locks -- number of new locks taken out by this call
3564 =item debug -- the debug file handle
3566 =item transcript -- the transcript file handle
3568 =item data -- an arrayref containing the data of the bugs
3569 corresponding to this request
3571 =item bugs -- an arrayref containing the bug numbers of the bugs
3572 corresponding to this request
3580 sub __begin_control {
3581 my %param = validate_with(params => \@_,
3582 spec => {bug => {type => SCALAR,
3585 archived => {type => BOOLEAN,
3588 command => {type => SCALAR,
3596 my ($debug,$transcript) = __handle_debug_transcript(@_);
3597 print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n";
3598 # print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n";
3599 $lockhash = $param{locks} if exists $param{locks};
3601 my $old_die = $SIG{__DIE__};
3602 $SIG{__DIE__} = *sig_die{CODE};
3604 ($new_locks, @data) =
3605 lock_read_all_merged_bugs(bug => $param{bug},
3606 $param{archived}?(location => 'archive'):(),
3607 exists $param{locks} ? (locks => $param{locks}):(),
3609 $locks += $new_locks;
3611 die "Unable to read any bugs successfully.";
3613 if (not $param{archived}) {
3614 for my $data (@data) {
3615 if ($data->{archived}) {
3616 die "Not altering archived bugs; see unarchive.";
3620 if (not __check_limit(data => \@data,
3621 exists $param{limit}?(limit => $param{limit}):(),
3622 transcript => $transcript,
3624 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3627 __handle_affected_packages(%param,data => \@data);
3628 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3629 print {$debug} "$param{bug} read $locks locks\n";
3630 if (not @data or not defined $data[0]) {
3631 print {$transcript} "No bug found for $param{bug}\n";
3632 die "No bug found for $param{bug}";
3635 add_recipients(data => \@data,
3636 recipients => $param{recipients},
3637 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3639 (__internal_request()?(transcript => $transcript):()),
3642 print {$debug} "$param{bug} read done\n";
3643 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3644 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3645 return (data => \@data,
3647 old_die => $old_die,
3648 new_locks => $new_locks,
3650 transcript => $transcript,
3652 exists $param{locks}?(locks => $param{locks}):(),
3656 =head2 __end_control
3658 __end_control(%info);
3660 Handles tearing down from a control request
3666 if (exists $info{new_locks} and $info{new_locks} > 0) {
3667 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3668 for (1..$info{new_locks}) {
3669 unfilelock(exists $info{locks}?$info{locks}:());
3673 $SIG{__DIE__} = $info{old_die};
3674 if (exists $info{param}{affected_bugs}) {
3675 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3677 add_recipients(recipients => $info{param}{recipients},
3678 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3679 data => $info{data},
3680 debug => $info{debug},
3681 transcript => $info{transcript},
3683 __handle_affected_packages(%{$info{param}},data=>$info{data});
3687 =head2 __check_limit
3689 __check_limit(data => \@data, limit => $param{limit});
3692 Checks to make sure that bugs match any limits; each entry of @data
3693 much satisfy the limit.
3695 Returns true if there are no entries in data, or there are no keys in
3696 limit; returns false (0) if there are any entries which do not match.
3698 The limit hashref elements can contain an arrayref of scalars to
3699 match; regexes are also acccepted. At least one of the entries in each
3700 element needs to match the corresponding field in all data for the
3707 my %param = validate_with(params => \@_,
3708 spec => {data => {type => ARRAYREF|SCALAR,
3710 limit => {type => HASHREF|UNDEF,
3712 transcript => {type => SCALARREF|HANDLE,
3717 my @data = make_list($param{data});
3719 not defined $param{limit} or
3720 not keys %{$param{limit}}) {
3723 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3724 my $going_to_fail = 0;
3725 for my $data (@data) {
3726 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3727 status => dclone($data),
3729 for my $field (keys %{$param{limit}}) {
3730 next unless exists $param{limit}{$field};
3732 my @data_fields = make_list($data->{$field});
3733 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3734 if (not ref $limit) {
3735 for my $data_field (@data_fields) {
3736 if ($data_field eq $limit) {
3742 elsif (ref($limit) eq 'Regexp') {
3743 for my $data_field (@data_fields) {
3744 if ($data_field =~ $limit) {
3751 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3756 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3757 "' does not match at least one of ".
3758 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3762 return $going_to_fail?0:1;
3770 We override die to specially handle unlocking files in the cases where
3771 we are called via eval. [If we're not called via eval, it doesn't
3777 if ($^S) { # in eval
3779 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3786 # =head2 __message_body_template
3788 # message_body_template('mail/ack',{ref=>'foo'});
3790 # Creates a message body using a template
3794 sub __message_body_template{
3795 my ($template,$extra_var) = @_;
3797 my $hole_var = {'&bugurl' =>
3799 'http://'.$config{cgi_domain}.'/'.
3800 Debbugs::CGI::bug_url($_[0]);
3804 my $body = fill_in_template(template => $template,
3805 variables => {config => \%config,
3808 hole_var => $hole_var,
3810 return fill_in_template(template => 'mail/message_body',
3811 variables => {config => \%config,
3815 hole_var => $hole_var,
3819 sub __all_undef_or_equal {
3821 return 1 if @values == 1 or @values == 0;
3822 my $not_def = grep {not defined $_} @values;
3823 if ($not_def == @values) {
3826 if ($not_def > 0 and $not_def != @values) {
3829 my $first_val = shift @values;
3830 for my $val (@values) {
3831 if ($first_val ne $val) {