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} "Unable to modify bugs so that they could be merged\n";
2160 for (1..$new_locks) {
2161 unfilelock($param{locks});
2164 __end_control(%info);
2168 # finally, we can merge the bugs
2169 my $action = "Merged ".join(' ',sort keys %merged_bugs);
2170 for my $data (@data) {
2171 my $old_data = dclone($data);
2172 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2174 append_action_to_log(bug => $data->{bug_num},
2177 old_data => $old_data,
2179 __return_append_to_log_options(%param,
2183 if not exists $param{append_log} or $param{append_log};
2184 writebug($data->{bug_num},$data);
2186 print {$transcript} "$action\n";
2187 # unlock the extra locks that we got earlier
2188 for (1..$new_locks) {
2189 unfilelock($param{locks});
2192 __end_control(%info);
2195 sub __allow_relocking{
2196 my ($locks,$bugs) = @_;
2198 my @locks = (@{$bugs},'merge');
2199 for my $lock (@locks) {
2200 my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}};
2201 next unless @lockfiles;
2202 $locks->{relockable}{$lockfiles[0]} = 0;
2206 sub __disallow_relocking{
2208 delete $locks->{relockable};
2211 sub __lock_and_load_merged_bugs{
2213 validate_with(params => \@_,
2215 {bugs_to_load => {type => ARRAYREF,
2216 default => sub {[]},
2218 data => {type => HASHREF|ARRAYREF,
2220 locks => {type => HASHREF,
2221 default => sub {{};},
2223 reload_all => {type => BOOLEAN,
2226 debug => {type => HANDLE,
2232 if (ref($param{data}) eq 'ARRAY') {
2233 for my $data (@{$param{data}}) {
2234 $data{$data->{bug_num}} = dclone($data);
2238 %data = %{dclone($param{data})};
2240 my @bugs_to_load = @{$param{bugs_to_load}};
2241 if ($param{reload_all}) {
2242 push @bugs_to_load, keys %data;
2245 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2246 @bugs_to_load = keys %temp;
2247 my %loaded_this_time;
2249 while ($bug_to_load = shift @bugs_to_load) {
2250 if (not $param{reload_all}) {
2251 next if exists $data{$bug_to_load};
2254 next if $loaded_this_time{$bug_to_load};
2257 if ($param{reload_all}) {
2258 if (exists $data{$bug_to_load}) {
2263 read_bug(bug => $bug_to_load,
2265 locks => $param{locks},
2267 die "Unable to load bug $bug_to_load";
2268 print {$param{debug}} "read bug $bug_to_load\n";
2269 $data{$data->{bug_num}} = $data;
2270 $new_locks += $lock_bug;
2271 $loaded_this_time{$data->{bug_num}} = 1;
2273 grep {not exists $data{$_}}
2274 split / /,$data->{mergedwith};
2276 return (\%data,$new_locks);
2280 sub __calculate_merge_status{
2281 my ($data_a,$data_h,$master_bug,$merge_status) = @_;
2282 my %merge_status = %{$merge_status // {}};
2284 my $bugs_to_merge = 0;
2285 for my $data (@{$data_a}) {
2286 # check to see if this bug is unmerged in the set
2287 if (not length $data->{mergedwith} or
2288 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2289 $merged_bugs{$data->{bug_num}} = 1;
2292 # the master_bug is the bug that every other bug is made to
2293 # look like. However, if merge is set, tags, fixed and found
2295 if ($data->{bug_num} == $master_bug) {
2296 for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2297 $merge_status{$_} = $data->{$_}
2300 if (defined $merge_status) {
2301 next unless $data->{bug_num} == $master_bug;
2303 $merge_status{tag} = {} if not exists $merge_status{tag};
2304 for my $tag (split /\s+/, $data->{keywords}) {
2305 $merge_status{tag}{$tag} = 1;
2307 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2308 for (qw(fixed found)) {
2309 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2312 return (\%merge_status,$bugs_to_merge);
2317 sub __calculate_merge_changes{
2318 my ($datas,$merge_status,$param) = @_;
2320 my @disallowed_changes;
2321 for my $data (@{$datas}) {
2322 # things that can be forced
2324 # * func is the function to set the new value
2326 # * key is the key of the function to set the value,
2328 # * modify_value is a function which is called to modify the new
2329 # value so that the function will accept it
2331 # * options is an ARRAYREF of options to pass to the function
2333 # * allowed is a BOOLEAN which controls whether this setting
2334 # is allowed to be different by default.
2335 my %force_functions =
2336 (forwarded => {func => \&set_forwarded,
2340 severity => {func => \&set_severity,
2344 blocks => {func => \&set_blocks,
2345 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2349 blockedby => {func => \&set_blocks,
2350 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2354 done => {func => \&set_done,
2358 owner => {func => \&owner,
2362 summary => {func => \&summary,
2366 affects => {func => \&affects,
2370 package => {func => \&set_package,
2374 keywords => {func => \&set_tag,
2376 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2379 fixed_versions => {func => \&set_fixed,
2381 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2384 found_versions => {func => \&set_found,
2386 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2390 for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2391 # if the ideal bug already has the field set properly, we
2393 if ($field eq 'keywords'){
2394 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2395 join(' ',sort keys %{$merge_status->{tag}});
2397 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2398 next if join(' ', sort @{$data->{$field}}) eq
2399 join(' ',sort keys %{$merge_status->{$field}});
2401 elsif ($merge_status->{$field} eq $data->{$field}) {
2406 bug => $data->{bug_num},
2407 orig_value => $data->{$field},
2409 (exists $force_functions{$field}{modify_value} ?
2410 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2411 $merge_status->{$field}),
2412 value => $merge_status->{$field},
2413 function => $force_functions{$field}{func},
2414 key => $force_functions{$field}{key},
2415 options => $force_functions{$field}{options},
2416 allowed => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0,
2418 $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
2419 $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
2420 if ($param->{force} or $change->{allowed}) {
2421 if ($field ne 'package' or $change->{allowed}) {
2422 push @{$changes{$data->{bug_num}}},$change;
2425 if ($param->{allow_reassign}) {
2426 if ($param->{reassign_different_sources}) {
2427 push @{$changes{$data->{bug_num}}},$change;
2430 # allow reassigning if binary_to_source returns at
2431 # least one of the same source packages
2432 my @merge_status_source =
2433 binary_to_source(package => $merge_status->{package},
2436 my @other_bug_source =
2437 binary_to_source(package => $data->{package},
2440 my %merge_status_sources;
2441 @merge_status_sources{@merge_status_source} =
2442 (1) x @merge_status_source;
2443 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2444 push @{$changes{$data->{bug_num}}},$change;
2449 push @disallowed_changes,$change;
2451 # blocks and blocked by are weird; we have to go through and
2452 # set blocks to the other half of the merged bugs
2454 return (\@disallowed_changes,\%changes);
2460 affects(bug => $ref,
2461 transcript => $transcript,
2462 ($dl > 0 ? (debug => $transcript):()),
2463 requester => $header{from},
2464 request_addr => $controlrequestaddr,
2466 affected_packages => \%affected_packages,
2467 recipients => \%recipients,
2475 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2478 This marks a bug as affecting packages which the bug is not actually
2479 in. This should only be used in cases where fixing the bug instantly
2480 resolves the problem in the other packages.
2482 By default, the packages are set to the list of packages passed.
2483 However, if you pass add => 1 or remove => 1, the list of packages
2484 passed are added or removed from the affects list, respectively.
2489 my %param = validate_with(params => \@_,
2490 spec => {bug => {type => SCALAR,
2493 # specific options here
2494 package => {type => SCALAR|ARRAYREF|UNDEF,
2497 add => {type => BOOLEAN,
2500 remove => {type => BOOLEAN,
2504 %append_action_options,
2507 if ($param{add} and $param{remove}) {
2508 croak "Asking to both add and remove affects is nonsensical";
2510 if (not defined $param{package}) {
2511 $param{package} = [];
2514 __begin_control(%param,
2515 command => 'affects'
2517 my ($debug,$transcript) =
2518 @info{qw(debug transcript)};
2519 my @data = @{$info{data}};
2520 my @bugs = @{$info{bugs}};
2522 for my $data (@data) {
2524 print {$debug} "Going to change affects\n";
2525 my @packages = splitpackages($data->{affects});
2527 @packages{@packages} = (1) x @packages;
2530 for my $package (make_list($param{package})) {
2531 next unless defined $package and length $package;
2532 if (not $packages{$package}) {
2533 $packages{$package} = 1;
2534 push @added,$package;
2538 $action = "Added indication that $data->{bug_num} affects ".
2539 english_join(\@added);
2542 elsif ($param{remove}) {
2544 for my $package (make_list($param{package})) {
2545 if ($packages{$package}) {
2546 next unless defined $package and length $package;
2547 delete $packages{$package};
2548 push @removed,$package;
2551 $action = "Removed indication that $data->{bug_num} affects " .
2552 english_join(\@removed);
2555 my %added_packages = ();
2556 my %removed_packages = %packages;
2558 for my $package (make_list($param{package})) {
2559 next unless defined $package and length $package;
2560 $packages{$package} = 1;
2561 delete $removed_packages{$package};
2562 $added_packages{$package} = 1;
2564 if (keys %removed_packages) {
2565 $action = "Removed indication that $data->{bug_num} affects ".
2566 english_join([keys %removed_packages]);
2567 $action .= "\n" if keys %added_packages;
2569 if (keys %added_packages) {
2570 $action .= "Added indication that $data->{bug_num} affects " .
2571 english_join([keys %added_packages]);
2574 if (not length $action) {
2575 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n";
2578 my $old_data = dclone($data);
2579 $data->{affects} = join(',',keys %packages);
2580 append_action_to_log(bug => $data->{bug_num},
2582 command => 'affects',
2584 old_data => $old_data,
2585 __return_append_to_log_options(
2590 if not exists $param{append_log} or $param{append_log};
2591 writebug($data->{bug_num},$data);
2592 print {$transcript} "$action\n";
2594 __end_control(%info);
2598 =head1 SUMMARY FUNCTIONS
2603 summary(bug => $ref,
2604 transcript => $transcript,
2605 ($dl > 0 ? (debug => $transcript):()),
2606 requester => $header{from},
2607 request_addr => $controlrequestaddr,
2609 affected_packages => \%affected_packages,
2610 recipients => \%recipients,
2616 print {$transcript} "Failed to mark $ref with summary foo: $@";
2619 Handles all setting of summary fields
2621 If summary is undef, unsets the summary
2623 If summary is 0, sets the summary to the first paragraph contained in
2626 If summary is a positive integer, sets the summary to the message specified.
2628 Otherwise, sets summary to the value passed.
2634 my %param = validate_with(params => \@_,
2635 spec => {bug => {type => SCALAR,
2638 # specific options here
2639 summary => {type => SCALAR|UNDEF,
2643 %append_action_options,
2646 # croak "summary must be numeric or undef" if
2647 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2649 __begin_control(%param,
2650 command => 'summary'
2652 my ($debug,$transcript) =
2653 @info{qw(debug transcript)};
2654 my @data = @{$info{data}};
2655 my @bugs = @{$info{bugs}};
2656 # figure out the log that we're going to use
2658 my $summary_msg = '';
2660 if (not defined $param{summary}) {
2662 print {$debug} "Removing summary fields\n";
2663 $action = 'Removed summary';
2665 elsif ($param{summary} =~ /^\d+$/) {
2667 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2668 if ($param{summary} == 0) {
2669 $log = $param{message};
2670 $summary_msg = @records + 1;
2673 if (($param{summary} - 1 ) > $#records) {
2674 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2676 my $record = $records[($param{summary} - 1 )];
2677 if ($record->{type} !~ /incoming-recv|recips/) {
2678 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2680 $summary_msg = $param{summary};
2681 $log = [$record->{text}];
2683 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2684 my $body = $p_o->{body};
2685 my $in_pseudoheaders = 0;
2687 # walk through body until we get non-blank lines
2688 for my $line (@{$body}) {
2689 if ($line =~ /^\s*$/) {
2690 if (length $paragraph) {
2691 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2697 $in_pseudoheaders = 0;
2700 # skip a paragraph if it looks like it's control or
2702 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2703 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2704 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2705 debug|(?:not|)forwarded|priority|
2706 (?:un|)block|limit|(?:un|)archive|
2707 reassign|retitle|affects|wrongpackage
2708 (?:un|force|)merge|user(?:category|tags?|)
2710 if (not length $paragraph) {
2711 print {$debug} "Found control/pseudo-headers and skiping them\n";
2712 $in_pseudoheaders = 1;
2716 next if $in_pseudoheaders;
2717 $paragraph .= $line ." \n";
2719 print {$debug} "Summary is going to be '$paragraph'\n";
2720 $summary = $paragraph;
2721 $summary =~ s/[\n\r]/ /g;
2722 if (not length $summary) {
2723 die "Unable to find summary message to use";
2725 # trim off a trailing spaces
2726 $summary =~ s/\ *$//;
2729 $summary = $param{summary};
2731 for my $data (@data) {
2732 print {$debug} "Going to change summary\n";
2733 if (((not defined $summary or not length $summary) and
2734 (not defined $data->{summary} or not length $data->{summary})) or
2735 $summary eq $data->{summary}) {
2736 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n";
2739 if (length $summary) {
2740 if (length $data->{summary}) {
2741 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2744 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2747 my $old_data = dclone($data);
2748 $data->{summary} = $summary;
2749 append_action_to_log(bug => $data->{bug_num},
2750 command => 'summary',
2751 old_data => $old_data,
2754 __return_append_to_log_options(
2759 if not exists $param{append_log} or $param{append_log};
2760 writebug($data->{bug_num},$data);
2761 print {$transcript} "$action\n";
2763 __end_control(%info);
2771 clone_bug(bug => $ref,
2772 transcript => $transcript,
2773 ($dl > 0 ? (debug => $transcript):()),
2774 requester => $header{from},
2775 request_addr => $controlrequestaddr,
2777 affected_packages => \%affected_packages,
2778 recipients => \%recipients,
2783 print {$transcript} "Failed to clone bug $ref bar: $@";
2786 Clones the given bug.
2788 We currently don't support cloning merged bugs, but this could be
2789 handled by internally unmerging, cloning, then remerging the bugs.
2794 my %param = validate_with(params => \@_,
2795 spec => {bug => {type => SCALAR,
2798 new_bugs => {type => ARRAYREF,
2800 new_clones => {type => HASHREF,
2804 %append_action_options,
2808 __begin_control(%param,
2811 my ($debug,$transcript) =
2812 @info{qw(debug transcript)};
2813 my @data = @{$info{data}};
2814 my @bugs = @{$info{bugs}};
2817 for my $data (@data) {
2818 if (length($data->{mergedwith})) {
2819 die "Bug is marked as being merged with others. Use an existing clone.\n";
2823 die "Not exactly one bug‽ This shouldn't happen.";
2825 my $data = $data[0];
2827 for my $newclone_id (@{$param{new_bugs}}) {
2828 my $new_bug_num = new_bug(copy => $data->{bug_num});
2829 $param{new_clones}{$newclone_id} = $new_bug_num;
2830 $clones{$newclone_id} = $new_bug_num;
2832 my @new_bugs = sort values %clones;
2834 for my $new_bug (@new_bugs) {
2835 # no collapsed ids or the higher collapsed id is not one less
2836 # than the next highest new bug
2837 if (not @collapsed_ids or
2838 $collapsed_ids[-1][1]+1 != $new_bug) {
2839 push @collapsed_ids,[$new_bug,$new_bug];
2842 $collapsed_ids[-1][1] = $new_bug;
2846 for my $ci (@collapsed_ids) {
2847 if ($ci->[0] == $ci->[1]) {
2848 push @collapsed,$ci->[0];
2851 push @collapsed,$ci->[0].'-'.$ci->[1]
2854 my $collapsed_str = english_join(\@collapsed);
2855 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2856 for my $new_bug (@new_bugs) {
2857 append_action_to_log(bug => $new_bug,
2859 __return_append_to_log_options(
2864 if not exists $param{append_log} or $param{append_log};
2866 append_action_to_log(bug => $data->{bug_num},
2868 __return_append_to_log_options(
2873 if not exists $param{append_log} or $param{append_log};
2874 writebug($data->{bug_num},$data);
2875 print {$transcript} "$action\n";
2876 __end_control(%info);
2877 # bugs that this bug is blocking are also blocked by the new clone(s)
2878 for my $bug (split ' ', $data->{blocks}) {
2879 for my $new_bug (@new_bugs) {
2880 set_blocks(bug => $new_bug,
2883 keys %common_options,
2884 keys %append_action_options),
2888 # bugs that this bug is blocked by are also blocking the new clone(s)
2889 for my $bug (split ' ', $data->{blockedby}) {
2890 for my $new_bug (@new_bugs) {
2891 set_blocks(bug => $bug,
2894 keys %common_options,
2895 keys %append_action_options),
2903 =head1 OWNER FUNCTIONS
2909 transcript => $transcript,
2910 ($dl > 0 ? (debug => $transcript):()),
2911 requester => $header{from},
2912 request_addr => $controlrequestaddr,
2914 recipients => \%recipients,
2920 print {$transcript} "Failed to mark $ref as having an owner: $@";
2923 Handles all setting of the owner field; given an owner of undef or of
2924 no length, indicates that a bug is not owned by anyone.
2929 my %param = validate_with(params => \@_,
2930 spec => {bug => {type => SCALAR,
2933 owner => {type => SCALAR|UNDEF,
2936 %append_action_options,
2940 __begin_control(%param,
2943 my ($debug,$transcript) =
2944 @info{qw(debug transcript)};
2945 my @data = @{$info{data}};
2946 my @bugs = @{$info{bugs}};
2948 for my $data (@data) {
2949 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2950 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2951 if (not defined $param{owner} or not length $param{owner}) {
2952 if (not defined $data->{owner} or not length $data->{owner}) {
2953 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n";
2957 $action = "Removed annotation that $config{bug} was owned by " .
2961 if ($data->{owner} eq $param{owner}) {
2962 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2965 if (length $data->{owner}) {
2966 $action = "Owner changed from $data->{owner} to $param{owner}.";
2969 $action = "Owner recorded as $param{owner}."
2972 my $old_data = dclone($data);
2973 $data->{owner} = $param{owner};
2974 append_action_to_log(bug => $data->{bug_num},
2977 old_data => $old_data,
2979 __return_append_to_log_options(
2984 if not exists $param{append_log} or $param{append_log};
2985 writebug($data->{bug_num},$data);
2986 print {$transcript} "$action\n";
2988 __end_control(%info);
2992 =head1 ARCHIVE FUNCTIONS
2999 bug_archive(bug => $bug_num,
3001 transcript => \$transcript,
3006 transcript("Unable to archive $bug_num\n");
3009 transcript($transcript);
3012 This routine archives a bug
3016 =item bug -- bug number
3018 =item check_archiveable -- check wether a bug is archiveable before
3019 archiving; defaults to 1
3021 =item archive_unarchived -- whether to archive bugs which have not
3022 previously been archived; defaults to 1. [Set to 0 when used from
3025 =item ignore_time -- whether to ignore time constraints when archiving
3026 a bug; defaults to 0.
3033 my %param = validate_with(params => \@_,
3034 spec => {bug => {type => SCALAR,
3037 check_archiveable => {type => BOOLEAN,
3040 archive_unarchived => {type => BOOLEAN,
3043 ignore_time => {type => BOOLEAN,
3047 %append_action_options,
3050 my %info = __begin_control(%param,
3051 command => 'archive',
3053 my ($debug,$transcript) = @info{qw(debug transcript)};
3054 my @data = @{$info{data}};
3055 my @bugs = @{$info{bugs}};
3056 my $action = "$config{bug} archived.";
3057 if ($param{check_archiveable} and
3058 not bug_archiveable(bug=>$param{bug},
3059 ignore_time => $param{ignore_time},
3061 print {$transcript} "Bug $param{bug} cannot be archived\n";
3062 die "Bug $param{bug} cannot be archived";
3064 if (not $param{archive_unarchived} and
3065 not exists $data[0]{unarchived}
3067 print {$transcript} "$param{bug} has not been archived previously\n";
3068 die "$param{bug} has not been archived previously";
3070 add_recipients(recipients => $param{recipients},
3073 transcript => $transcript,
3075 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3076 for my $bug (@bugs) {
3077 if ($param{check_archiveable}) {
3078 die "Bug $bug cannot be archived (but $param{bug} can?)"
3079 unless bug_archiveable(bug=>$bug,
3080 ignore_time => $param{ignore_time},
3084 # If we get here, we can archive/remove this bug
3085 print {$debug} "$param{bug} removing\n";
3086 for my $bug (@bugs) {
3087 #print "$param{bug} removing $bug\n" if $debug;
3088 my $dir = get_hashname($bug);
3089 # First indicate that this bug is being archived
3090 append_action_to_log(bug => $bug,
3092 command => 'archive',
3093 # we didn't actually change the data
3094 # when we archived, so we don't pass
3095 # a real new_data or old_data
3098 __return_append_to_log_options(
3103 if not exists $param{append_log} or $param{append_log};
3104 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3105 if ($config{save_old_bugs}) {
3106 mkpath("$config{spool_dir}/archive/$dir");
3107 foreach my $file (@files_to_remove) {
3108 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3109 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3110 # we need to bail out here if things have
3111 # gone horribly wrong to avoid removing a
3113 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3116 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3118 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3119 print {$debug} "deleted $bug (from $param{bug})\n";
3121 bughook_archive(@bugs);
3122 __end_control(%info);
3125 =head2 bug_unarchive
3129 bug_unarchive(bug => $bug_num,
3131 transcript => \$transcript,
3136 transcript("Unable to archive bug: $bug_num");
3138 transcript($transcript);
3140 This routine unarchives a bug
3145 my %param = validate_with(params => \@_,
3146 spec => {bug => {type => SCALAR,
3150 %append_action_options,
3154 my %info = __begin_control(%param,
3156 command=>'unarchive');
3157 my ($debug,$transcript) =
3158 @info{qw(debug transcript)};
3159 my @data = @{$info{data}};
3160 my @bugs = @{$info{bugs}};
3161 my $action = "$config{bug} unarchived.";
3162 my @files_to_remove;
3163 for my $bug (@bugs) {
3164 print {$debug} "$param{bug} removing $bug\n";
3165 my $dir = get_hashname($bug);
3166 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3167 mkpath("archive/$dir");
3168 foreach my $file (@files_to_copy) {
3169 # die'ing here sucks
3170 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3171 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3172 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3174 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3175 print {$transcript} "Unarchived $config{bug} $bug\n";
3177 unlink(@files_to_remove) or die "Unable to unlink bugs";
3178 # Indicate that this bug has been archived previously
3179 for my $bug (@bugs) {
3180 my $newdata = readbug($bug);
3181 my $old_data = dclone($newdata);
3182 if (not defined $newdata) {
3183 print {$transcript} "$config{bug} $bug disappeared!\n";
3184 die "Bug $bug disappeared!";
3186 $newdata->{unarchived} = time;
3187 append_action_to_log(bug => $bug,
3189 command => 'unarchive',
3190 new_data => $newdata,
3191 old_data => $old_data,
3192 __return_append_to_log_options(
3197 if not exists $param{append_log} or $param{append_log};
3198 writebug($bug,$newdata);
3200 __end_control(%info);
3203 =head2 append_action_to_log
3205 append_action_to_log
3207 This should probably be moved to Debbugs::Log; have to think that out
3212 sub append_action_to_log{
3213 my %param = validate_with(params => \@_,
3214 spec => {bug => {type => SCALAR,
3217 new_data => {type => HASHREF,
3220 old_data => {type => HASHREF,
3223 command => {type => SCALAR,
3226 action => {type => SCALAR,
3228 requester => {type => SCALAR,
3231 request_addr => {type => SCALAR,
3234 location => {type => SCALAR,
3237 message => {type => SCALAR|ARRAYREF,
3240 recips => {type => SCALAR|ARRAYREF,
3243 desc => {type => SCALAR,
3246 get_lock => {type => BOOLEAN,
3249 locks => {type => HASHREF,
3253 # append_action_options here
3254 # because some of these
3255 # options aren't actually
3256 # optional, even though the
3257 # original function doesn't
3261 # Fix this to use $param{location}
3262 my $log_location = buglog($param{bug});
3263 die "Unable to find .log for $param{bug}"
3264 if not defined $log_location;
3265 if ($param{get_lock}) {
3266 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3270 my $logfh = IO::File->new(">>$log_location") or
3271 die "Unable to open $log_location for appending: $!";
3272 # determine difference between old and new
3274 if (exists $param{old_data} and exists $param{new_data}) {
3275 my $old_data = dclone($param{old_data});
3276 my $new_data = dclone($param{new_data});
3277 for my $key (keys %{$old_data}) {
3278 if (not exists $Debbugs::Status::fields{$key}) {
3279 delete $old_data->{$key};
3282 next unless exists $new_data->{$key};
3283 next unless defined $new_data->{$key};
3284 if (not defined $old_data->{$key}) {
3285 delete $old_data->{$key};
3288 if (ref($new_data->{$key}) and
3289 ref($old_data->{$key}) and
3290 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3291 local $Storable::canonical = 1;
3292 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3293 delete $new_data->{$key};
3294 delete $old_data->{$key};
3297 elsif ($new_data->{$key} eq $old_data->{$key}) {
3298 delete $new_data->{$key};
3299 delete $old_data->{$key};
3302 for my $key (keys %{$new_data}) {
3303 if (not exists $Debbugs::Status::fields{$key}) {
3304 delete $new_data->{$key};
3307 next unless exists $old_data->{$key};
3308 next unless defined $old_data->{$key};
3309 if (not defined $new_data->{$key} or
3310 not exists $Debbugs::Status::fields{$key}) {
3311 delete $new_data->{$key};
3314 if (ref($new_data->{$key}) and
3315 ref($old_data->{$key}) and
3316 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3317 local $Storable::canonical = 1;
3318 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3319 delete $new_data->{$key};
3320 delete $old_data->{$key};
3323 elsif ($new_data->{$key} eq $old_data->{$key}) {
3324 delete $new_data->{$key};
3325 delete $old_data->{$key};
3328 $data_diff .= "<!-- new_data:\n";
3330 for my $key (keys %{$new_data}) {
3331 if (not exists $Debbugs::Status::fields{$key}) {
3332 warn "No such field $key";
3335 $nd{$key} = $new_data->{$key};
3336 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3338 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3339 $data_diff .= "-->\n";
3340 $data_diff .= "<!-- old_data:\n";
3342 for my $key (keys %{$old_data}) {
3343 if (not exists $Debbugs::Status::fields{$key}) {
3344 warn "No such field $key";
3347 $od{$key} = $old_data->{$key};
3348 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3350 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3351 $data_diff .= "-->\n";
3354 (exists $param{command} ?
3355 "<!-- command:".html_escape($param{command})." -->\n":""
3357 (length $param{requester} ?
3358 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3360 (length $param{request_addr} ?
3361 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3363 "<!-- time:".time()." -->\n",
3365 "<strong>".html_escape($param{action})."</strong>\n");
3366 if (length $param{requester}) {
3367 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3369 if (length $param{request_addr}) {
3370 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3372 if (length $param{desc}) {
3373 $msg .= ":<br>\n$param{desc}\n";
3378 push @records, {type => 'html',
3382 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3383 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3384 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3385 text => join('',make_list($param{message})),
3388 write_log_records(logfh=>$logfh,
3389 records => \@records,
3391 close $logfh or die "Unable to close $log_location: $!";
3392 if ($param{get_lock}) {
3393 unfilelock(exists $param{locks}?$param{locks}:());
3401 =head1 PRIVATE FUNCTIONS
3403 =head2 __handle_affected_packages
3405 __handle_affected_packages(affected_packages => {},
3413 sub __handle_affected_packages{
3414 my %param = validate_with(params => \@_,
3415 spec => {%common_options,
3416 data => {type => ARRAYREF|HASHREF
3421 for my $data (make_list($param{data})) {
3422 next unless exists $data->{package} and defined $data->{package};
3423 my @packages = split /\s*,\s*/,$data->{package};
3424 @{$param{affected_packages}}{@packages} = (1) x @packages;
3428 =head2 __handle_debug_transcript
3430 my ($debug,$transcript) = __handle_debug_transcript(%param);
3432 Returns a debug and transcript filehandle
3437 sub __handle_debug_transcript{
3438 my %param = validate_with(params => \@_,
3439 spec => {%common_options},
3442 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3443 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3444 return ($debug,$transcript);
3451 Produces a small bit of bug information to kick out to the transcript
3458 next unless defined $data and exists $data->{bug_num};
3459 $return .= "Bug #".($data->{bug_num}||'').
3460 ((defined $data->{done} and length $data->{done})?
3461 " {Done: $data->{done}}":''
3463 " [".($data->{package}||'(no package)'). "] ".
3464 ($data->{subject}||'(no subject)')."\n";
3470 =head2 __internal_request
3472 __internal_request()
3473 __internal_request($level)
3475 Returns true if the caller of the function calling __internal_request
3476 belongs to __PACKAGE__
3478 This allows us to be magical, and don't bother to print bug info if
3479 the second caller is from this package, amongst other things.
3481 An optional level is allowed, which increments the number of levels to
3482 check by the given value. [This is basically for use by internal
3483 functions like __begin_control which are always called by
3488 sub __internal_request{
3490 $l = 0 if not defined $l;
3491 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3497 sub __return_append_to_log_options{
3499 my $action = $param{action} if exists $param{action};
3500 if (not exists $param{requester}) {
3501 $param{requester} = $config{control_internal_requester};
3503 if (not exists $param{request_addr}) {
3504 $param{request_addr} = $config{control_internal_request_addr};
3506 if (not exists $param{message}) {
3507 my $date = rfc822_date();
3508 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3509 variables => {request_addr => $param{request_addr},
3510 requester => $param{requester},
3516 if (not defined $action) {
3517 carp "Undefined action!";
3518 $action = "unknown action";
3520 return (action => $action,
3521 hash_slice(%param,keys %append_action_options),
3525 =head2 __begin_control
3527 my %info = __begin_control(%param,
3529 command=>'unarchive');
3530 my ($debug,$transcript) = @info{qw(debug transcript)};
3531 my @data = @{$info{data}};
3532 my @bugs = @{$info{bugs}};
3535 Starts the process of modifying a bug; handles all of the generic
3536 things that almost every control request needs
3538 Returns a hash containing
3542 =item new_locks -- number of new locks taken out by this call
3544 =item debug -- the debug file handle
3546 =item transcript -- the transcript file handle
3548 =item data -- an arrayref containing the data of the bugs
3549 corresponding to this request
3551 =item bugs -- an arrayref containing the bug numbers of the bugs
3552 corresponding to this request
3560 sub __begin_control {
3561 my %param = validate_with(params => \@_,
3562 spec => {bug => {type => SCALAR,
3565 archived => {type => BOOLEAN,
3568 command => {type => SCALAR,
3576 my ($debug,$transcript) = __handle_debug_transcript(@_);
3577 print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n";
3578 # print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n";
3579 $lockhash = $param{locks} if exists $param{locks};
3581 my $old_die = $SIG{__DIE__};
3582 $SIG{__DIE__} = *sig_die{CODE};
3584 ($new_locks, @data) =
3585 lock_read_all_merged_bugs(bug => $param{bug},
3586 $param{archived}?(location => 'archive'):(),
3587 exists $param{locks} ? (locks => $param{locks}):(),
3589 $locks += $new_locks;
3591 die "Unable to read any bugs successfully.";
3593 if (not $param{archived}) {
3594 for my $data (@data) {
3595 if ($data->{archived}) {
3596 die "Not altering archived bugs; see unarchive.";
3600 if (not __check_limit(data => \@data,
3601 exists $param{limit}?(limit => $param{limit}):(),
3602 transcript => $transcript,
3604 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3607 __handle_affected_packages(%param,data => \@data);
3608 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3609 print {$debug} "$param{bug} read $locks locks\n";
3610 if (not @data or not defined $data[0]) {
3611 print {$transcript} "No bug found for $param{bug}\n";
3612 die "No bug found for $param{bug}";
3615 add_recipients(data => \@data,
3616 recipients => $param{recipients},
3617 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3619 (__internal_request()?(transcript => $transcript):()),
3622 print {$debug} "$param{bug} read done\n";
3623 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3624 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3625 return (data => \@data,
3627 old_die => $old_die,
3628 new_locks => $new_locks,
3630 transcript => $transcript,
3632 exists $param{locks}?(locks => $param{locks}):(),
3636 =head2 __end_control
3638 __end_control(%info);
3640 Handles tearing down from a control request
3646 if (exists $info{new_locks} and $info{new_locks} > 0) {
3647 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3648 for (1..$info{new_locks}) {
3649 unfilelock(exists $info{locks}?$info{locks}:());
3653 $SIG{__DIE__} = $info{old_die};
3654 if (exists $info{param}{affected_bugs}) {
3655 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3657 add_recipients(recipients => $info{param}{recipients},
3658 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3659 data => $info{data},
3660 debug => $info{debug},
3661 transcript => $info{transcript},
3663 __handle_affected_packages(%{$info{param}},data=>$info{data});
3667 =head2 __check_limit
3669 __check_limit(data => \@data, limit => $param{limit});
3672 Checks to make sure that bugs match any limits; each entry of @data
3673 much satisfy the limit.
3675 Returns true if there are no entries in data, or there are no keys in
3676 limit; returns false (0) if there are any entries which do not match.
3678 The limit hashref elements can contain an arrayref of scalars to
3679 match; regexes are also acccepted. At least one of the entries in each
3680 element needs to match the corresponding field in all data for the
3687 my %param = validate_with(params => \@_,
3688 spec => {data => {type => ARRAYREF|SCALAR,
3690 limit => {type => HASHREF|UNDEF,
3692 transcript => {type => SCALARREF|HANDLE,
3697 my @data = make_list($param{data});
3699 not defined $param{limit} or
3700 not keys %{$param{limit}}) {
3703 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3704 my $going_to_fail = 0;
3705 for my $data (@data) {
3706 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3707 status => dclone($data),
3709 for my $field (keys %{$param{limit}}) {
3710 next unless exists $param{limit}{$field};
3712 my @data_fields = make_list($data->{$field});
3713 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3714 if (not ref $limit) {
3715 for my $data_field (@data_fields) {
3716 if ($data_field eq $limit) {
3722 elsif (ref($limit) eq 'Regexp') {
3723 for my $data_field (@data_fields) {
3724 if ($data_field =~ $limit) {
3731 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3736 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3737 "' does not match at least one of ".
3738 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3742 return $going_to_fail?0:1;
3750 We override die to specially handle unlocking files in the cases where
3751 we are called via eval. [If we're not called via eval, it doesn't
3757 if ($^S) { # in eval
3759 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3766 # =head2 __message_body_template
3768 # message_body_template('mail/ack',{ref=>'foo'});
3770 # Creates a message body using a template
3774 sub __message_body_template{
3775 my ($template,$extra_var) = @_;
3777 my $hole_var = {'&bugurl' =>
3779 'http://'.$config{cgi_domain}.'/'.
3780 Debbugs::CGI::bug_url($_[0]);
3784 my $body = fill_in_template(template => $template,
3785 variables => {config => \%config,
3788 hole_var => $hole_var,
3790 return fill_in_template(template => 'mail/message_body',
3791 variables => {config => \%config,
3795 hole_var => $hole_var,
3799 sub __all_undef_or_equal {
3801 return 1 if @values == 1 or @values == 0;
3802 my $not_def = grep {not defined $_} @values;
3803 if ($not_def == @values) {
3806 if ($not_def > 0 and $not_def != @values) {
3809 my $first_val = shift @values;
3810 for my $val (@values) {
3811 if ($first_val ne $val) {