1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Control;
14 Debbugs::Control -- Routines for modifying the state of bugs
23 This module is an abstraction of a lot of functions which originally
24 were only present in service.in, but as time has gone on needed to be
25 called from elsewhere.
27 All of the public functions take the following options:
31 =item debug -- scalar reference to which debbuging information is
34 =item transcript -- scalar reference to which transcript information
37 =item affected_bugs -- hashref which is updated with bugs affected by
43 Functions which should (probably) append to the .log file take the
48 =item requester -- Email address of the individual who requested the change
50 =item request_addr -- Address to which the request was sent
52 =item request_nn -- Name of queue file which caused this request
54 =item request_msgid -- Message id of message which caused this request
56 =item location -- Optional location; currently ignored but may be
57 supported in the future for updating archived bugs upon archival
59 =item message -- The original message which caused the action to be taken
61 =item append_log -- Whether or not to append information to the log.
65 B<append_log> (for most functions) is a special option. When set to
66 false, no appending to the log is done at all. When it is not present,
67 the above information is faked, and appended to the log file. When it
68 is true, the above options must be present, and their values are used.
71 =head1 GENERAL FUNCTIONS
77 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
78 use base qw(Exporter);
82 $DEBUG = 0 unless defined $DEBUG;
85 %EXPORT_TAGS = (done => [qw(set_done)],
86 submitter => [qw(set_submitter)],
87 severity => [qw(set_severity)],
88 affects => [qw(affects)],
89 summary => [qw(summary)],
91 title => [qw(set_title)],
92 forward => [qw(set_forwarded)],
93 found => [qw(set_found set_fixed)],
94 fixed => [qw(set_found set_fixed)],
95 package => [qw(set_package)],
96 block => [qw(set_blocks)],
97 merge => [qw(set_merged)],
99 clone => [qw(clone_bug)],
100 archive => [qw(bug_archive bug_unarchive),
102 log => [qw(append_action_to_log),
106 Exporter::export_ok_tags(keys %EXPORT_TAGS);
107 $EXPORT_TAGS{all} = [@EXPORT_OK];
110 use Debbugs::Config qw(:config);
111 use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions);
112 use Debbugs::Status qw(bug_archiveable :read :hook writebug new_bug splitpackages split_status_fields get_bug_status);
113 use Debbugs::CGI qw(html_escape);
114 use Debbugs::Log qw(:misc :write);
115 use Debbugs::Recipients qw(:add);
116 use Debbugs::Packages qw(:versions :mapping);
118 use Data::Dumper qw();
119 use Params::Validate qw(validate_with :types);
120 use File::Path qw(mkpath);
121 use File::Copy qw(copy);
124 use Debbugs::Text qw(:templates);
126 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
127 use Debbugs::MIME qw(create_mime_message);
129 use Mail::RFC822::Address qw();
131 use POSIX qw(strftime);
133 use Storable qw(dclone nfreeze);
134 use List::Util qw(first max);
138 # These are a set of options which are common to all of these functions
140 my %common_options = (debug => {type => SCALARREF|HANDLE,
143 transcript => {type => SCALARREF|HANDLE,
146 affected_bugs => {type => HASHREF,
149 affected_packages => {type => HASHREF,
152 recipients => {type => HASHREF,
155 limit => {type => HASHREF,
158 show_bug_info => {type => BOOLEAN,
161 request_subject => {type => SCALAR,
162 default => 'Unknown Subject',
164 request_msgid => {type => SCALAR,
167 request_nn => {type => SCALAR,
170 request_replyto => {type => SCALAR,
173 locks => {type => HASHREF,
179 my %append_action_options =
180 (action => {type => SCALAR,
183 requester => {type => SCALAR,
186 request_addr => {type => SCALAR,
189 location => {type => SCALAR,
192 message => {type => SCALAR|ARRAYREF,
195 append_log => {type => BOOLEAN,
197 depends => [qw(requester request_addr),
201 # locks is both an append_action option, and a common option;
202 # it's ok for it to be in both places.
203 locks => {type => HASHREF,
211 # this is just a generic stub for Debbugs::Control functions.
216 # set_foo(bug => $ref,
217 # transcript => $transcript,
218 # ($dl > 0 ? (debug => $transcript):()),
219 # requester => $header{from},
220 # request_addr => $controlrequestaddr,
222 # affected_packages => \%affected_packages,
223 # recipients => \%recipients,
229 # print {$transcript} "Failed to set foo $ref bar: $@";
237 # my %param = validate_with(params => \@_,
238 # spec => {bug => {type => SCALAR,
239 # regex => qr/^\d+$/,
241 # # specific options here
243 # %append_action_options,
247 # __begin_control(%param,
250 # my ($debug,$transcript) =
251 # @info{qw(debug transcript)};
252 # my @data = @{$info{data}};
253 # my @bugs = @{$info{bugs}};
256 # for my $data (@data) {
257 # append_action_to_log(bug => $data->{bug_num},
259 # __return_append_to_log_options(
264 # if not exists $param{append_log} or $param{append_log};
265 # writebug($data->{bug_num},$data);
266 # print {$transcript} "$action\n";
268 # __end_control(%info);
275 set_block(bug => $ref,
276 transcript => $transcript,
277 ($dl > 0 ? (debug => $transcript):()),
278 requester => $header{from},
279 request_addr => $controlrequestaddr,
281 affected_packages => \%affected_packages,
282 recipients => \%recipients,
288 print {$transcript} "Failed to set blockers of $ref: $@";
291 Alters the set of bugs that block this bug from being fixed
293 This requires altering both this bug (and those it's merged with) as
294 well as the bugs that block this bug from being fixed (and those that
299 =item block -- scalar or arrayref of blocking bugs to set, add or remove
301 =item add -- if true, add blocking bugs
303 =item remove -- if true, remove blocking bugs
310 my %param = validate_with(params => \@_,
311 spec => {bug => {type => SCALAR,
314 # specific options here
315 block => {type => SCALAR|ARRAYREF,
318 add => {type => BOOLEAN,
321 remove => {type => BOOLEAN,
325 %append_action_options,
328 if ($param{add} and $param{remove}) {
329 croak "It's nonsensical to add and remove the same blocking bugs";
331 if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
332 croak "Invalid blocking bug(s):".
333 join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
339 elsif ($param{remove}) {
344 __begin_control(%param,
347 my ($debug,$transcript) =
348 @info{qw(debug transcript)};
349 my @data = @{$info{data}};
350 my @bugs = @{$info{bugs}};
353 # The first bit of this code is ugly, and should be cleaned up.
354 # Its purpose is to populate %removed_blockers and %add_blockers
355 # with all of the bugs that should be added or removed as blockers
356 # of all of the bugs which are merged with $param{bug}
359 for my $blocker (make_list($param{block})) {
360 next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
361 my $data = read_bug(bug=>$blocker,
363 if (defined $data and not $data->{archive}) {
364 $data = split_status_fields($data);
365 $ok_blockers{$blocker} = 1;
367 push @merged_bugs, make_list($data->{mergedwith});
368 @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
371 $bad_blockers{$blocker} = 1;
375 # throw an error if we are setting the blockers and there is a bad
377 if (keys %bad_blockers and $mode eq 'set') {
378 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
379 keys %ok_blockers?'':" and no known blocking bug(s)";
381 # if there are no ok blockers and we are not setting the blockers,
383 if (not keys %ok_blockers and $mode ne 'set') {
384 print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
385 if (keys %bad_blockers) {
386 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
388 __end_control(%info);
392 my @change_blockers = keys %ok_blockers;
394 my %removed_blockers;
397 my @blockers = map {split ' ', $_->{blockedby}} @data;
399 @blockers{@blockers} = (1) x @blockers;
401 # it is nonsensical for a bug to block itself (or a merged
402 # partner); We currently don't allow removal because we'd possibly
406 @bugs{@bugs} = (1) x @bugs;
407 for my $blocker (@change_blockers) {
408 if ($bugs{$blocker}) {
409 croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
412 @blockers = keys %blockers;
414 %removed_blockers = ();
415 for my $blocker (@change_blockers) {
416 next if exists $blockers{$blocker};
417 $blockers{$blocker} = 1;
418 $added_blockers{$blocker} = 1;
421 elsif ($param{remove}) {
422 %added_blockers = ();
423 for my $blocker (@change_blockers) {
424 next if exists $removed_blockers{$blocker};
425 delete $blockers{$blocker};
426 $removed_blockers{$blocker} = 1;
430 @removed_blockers{@blockers} = (1) x @blockers;
432 for my $blocker (@change_blockers) {
433 next if exists $blockers{$blocker};
434 $blockers{$blocker} = 1;
435 if (exists $removed_blockers{$blocker}) {
436 delete $removed_blockers{$blocker};
439 $added_blockers{$blocker} = 1;
443 my @new_blockers = keys %blockers;
444 for my $data (@data) {
445 my $old_data = dclone($data);
446 # remove blockers and/or add new ones as appropriate
447 if ($data->{blockedby} eq '') {
448 print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n";
450 print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n";
452 if ($data->{blocks} eq '') {
453 print {$transcript} "$data->{bug_num} was not blocking any bugs.\n";
455 print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n";
458 push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
459 push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers;
460 $action = ucfirst(join ('; ',@changed)) if @changed;
462 print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n"
463 unless __internal_request();
466 $data->{blockedby} = join(' ',keys %blockers);
467 append_action_to_log(bug => $data->{bug_num},
469 old_data => $old_data,
472 __return_append_to_log_options(
477 if not exists $param{append_log} or $param{append_log};
478 writebug($data->{bug_num},$data);
479 print {$transcript} "$action\n";
481 # we do this bit below to avoid code duplication
483 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
484 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
486 for my $add_remove (keys %mungable_blocks) {
490 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
491 next if $munge_blockers{$blocker};
492 my ($temp_locks, @blocking_data) =
493 lock_read_all_merged_bugs(bug => $blocker,
494 ($param{archived}?(location => 'archive'):()),
495 exists $param{locks}?(locks => $param{locks}):(),
497 $locks+= $temp_locks;
498 $new_locks+=$temp_locks;
499 if (not @blocking_data) {
500 for (1..$new_locks) {
501 unfilelock(exists $param{locks}?$param{locks}:());
504 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
506 for (map {$_->{bug_num}} @blocking_data) {
507 $munge_blockers{$_} = 1;
509 for my $data (@blocking_data) {
510 my $old_data = dclone($data);
512 my @blocks = split ' ', $data->{blocks};
513 @blocks{@blocks} = (1) x @blocks;
515 for my $bug (@bugs) {
516 if ($add_remove eq 'remove') {
517 next unless exists $blocks{$bug};
518 delete $blocks{$bug};
521 next if exists $blocks{$bug};
526 $data->{blocks} = join(' ',sort keys %blocks);
527 my $action = ($add_remove eq 'add'?'Added':'Removed').
528 " indication that bug $data->{bug_num} blocks ".
530 append_action_to_log(bug => $data->{bug_num},
532 old_data => $old_data,
535 __return_append_to_log_options(%param,
539 writebug($data->{bug_num},$data);
541 __handle_affected_packages(%param,data=>\@blocking_data);
542 add_recipients(recipients => $param{recipients},
543 actions_taken => {blocks => 1},
544 data => \@blocking_data,
546 transcript => $transcript,
549 for (1..$new_locks) {
550 unfilelock(exists $param{locks}?$param{locks}:());
555 __end_control(%info);
564 transcript => $transcript,
565 ($dl > 0 ? (debug => $transcript):()),
566 requester => $header{from},
567 request_addr => $controlrequestaddr,
569 affected_packages => \%affected_packages,
570 recipients => \%recipients,
577 print {$transcript} "Failed to set tag on $ref: $@";
581 Sets, adds, or removes the specified tags on a bug
585 =item tag -- scalar or arrayref of tags to set, add or remove
587 =item add -- if true, add tags
589 =item remove -- if true, remove tags
591 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
599 my %param = validate_with(params => \@_,
600 spec => {bug => {type => SCALAR,
603 # specific options here
604 tag => {type => SCALAR|ARRAYREF,
607 add => {type => BOOLEAN,
610 remove => {type => BOOLEAN,
613 warn_on_bad_tags => {type => BOOLEAN,
617 %append_action_options,
620 if ($param{add} and $param{remove}) {
621 croak "It's nonsensical to add and remove the same tags";
625 __begin_control(%param,
628 my ($debug,$transcript) =
629 @info{qw(debug transcript)};
630 my @data = @{$info{data}};
631 my @bugs = @{$info{bugs}};
632 my @tags = make_list($param{tag});
633 if (not @tags and ($param{remove} or $param{add})) {
634 if ($param{remove}) {
635 print {$transcript} "Requested to remove no tags; doing nothing.\n";
638 print {$transcript} "Requested to add no tags; doing nothing.\n";
640 __end_control(%info);
643 # first things first, make the versions fully qualified source
645 for my $data (@data) {
646 my $action = 'Did not alter tags';
648 my %tag_removed = ();
649 my %fixed_removed = ();
650 my @old_tags = split /\,?\s+/, $data->{keywords};
652 @tags{@old_tags} = (1) x @old_tags;
654 my $old_data = dclone($data);
655 if (not $param{add} and not $param{remove}) {
656 $tag_removed{$_} = 1 for @old_tags;
660 for my $tag (@tags) {
661 if (not $param{remove} and
662 not defined first {$_ eq $tag} @{$config{tags}}) {
663 push @bad_tags, $tag;
667 if (not exists $tags{$tag}) {
669 $tag_added{$tag} = 1;
672 elsif ($param{remove}) {
673 if (exists $tags{$tag}) {
675 $tag_removed{$tag} = 1;
679 if (exists $tag_removed{$tag}) {
680 delete $tag_removed{$tag};
683 $tag_added{$tag} = 1;
688 if (@bad_tags and $param{warn_on_bad_tags}) {
689 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
690 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
692 $data->{keywords} = join(' ',keys %tags);
695 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
696 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
697 $action = ucfirst(join ('; ',@changed)) if @changed;
699 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
700 unless __internal_request();
704 append_action_to_log(bug => $data->{bug_num},
707 old_data => $old_data,
709 __return_append_to_log_options(
714 if not exists $param{append_log} or $param{append_log};
715 writebug($data->{bug_num},$data);
716 print {$transcript} "$action\n";
718 __end_control(%info);
726 set_severity(bug => $ref,
727 transcript => $transcript,
728 ($dl > 0 ? (debug => $transcript):()),
729 requester => $header{from},
730 request_addr => $controlrequestaddr,
732 affected_packages => \%affected_packages,
733 recipients => \%recipients,
734 severity => 'normal',
739 print {$transcript} "Failed to set the severity of bug $ref: $@";
742 Sets the severity of a bug. If severity is not passed, is undefined,
743 or has zero length, sets the severity to the default severity.
748 my %param = validate_with(params => \@_,
749 spec => {bug => {type => SCALAR,
752 # specific options here
753 severity => {type => SCALAR|UNDEF,
754 default => $config{default_severity},
757 %append_action_options,
760 if (not defined $param{severity} or
761 not length $param{severity}
763 $param{severity} = $config{default_severity};
766 # check validity of new severity
767 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
768 die "Severity '$param{severity}' is not a valid severity level";
771 __begin_control(%param,
772 command => 'severity'
774 my ($debug,$transcript) =
775 @info{qw(debug transcript)};
776 my @data = @{$info{data}};
777 my @bugs = @{$info{bugs}};
780 for my $data (@data) {
781 if (not defined $data->{severity}) {
782 $data->{severity} = $param{severity};
783 $action = "Severity set to '$param{severity}'";
786 if ($data->{severity} eq '') {
787 $data->{severity} = $config{default_severity};
789 if ($data->{severity} eq $param{severity}) {
790 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
793 $action = "Severity set to '$param{severity}' from '$data->{severity}'";
794 $data->{severity} = $param{severity};
796 append_action_to_log(bug => $data->{bug_num},
798 __return_append_to_log_options(
803 if not exists $param{append_log} or $param{append_log};
804 writebug($data->{bug_num},$data);
805 print {$transcript} "$action\n";
807 __end_control(%info);
814 set_done(bug => $ref,
815 transcript => $transcript,
816 ($dl > 0 ? (debug => $transcript):()),
817 requester => $header{from},
818 request_addr => $controlrequestaddr,
820 affected_packages => \%affected_packages,
821 recipients => \%recipients,
826 print {$transcript} "Failed to set foo $ref bar: $@";
834 my %param = validate_with(params => \@_,
835 spec => {bug => {type => SCALAR,
838 reopen => {type => BOOLEAN,
841 submitter => {type => SCALAR,
844 clear_fixed => {type => BOOLEAN,
847 notify_submitter => {type => BOOLEAN,
850 original_report => {type => SCALARREF,
853 done => {type => SCALAR|UNDEF,
857 %append_action_options,
861 if (exists $param{submitter} and
862 not Mail::RFC822::Address::valid($param{submitter})) {
863 die "New submitter address '$param{submitter}' is not a valid e-mail address";
865 if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address
866 $param{done} = $param{requester};
868 if (exists $param{done} and
869 (not defined $param{done} or
870 not length $param{done})) {
876 __begin_control(%param,
877 command => $param{reopen}?'reopen':'done',
879 my ($debug,$transcript) =
880 @info{qw(debug transcript)};
881 my @data = @{$info{data}};
882 my @bugs = @{$info{bugs}};
885 if ($param{reopen}) {
886 # avoid warning multiple times if there are fixed versions
888 for my $data (@data) {
889 if (not exists $data->{done} or
890 not defined $data->{done} or
891 not length $data->{done}) {
892 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
893 __end_control(%info);
896 if (@{$data->{fixed_versions}} and $warn_fixed) {
897 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
898 print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n";
902 $action = "Bug reopened";
903 for my $data (@data) {
904 my $old_data = dclone($data);
906 append_action_to_log(bug => $data->{bug_num},
909 old_data => $old_data,
911 __return_append_to_log_options(
916 if not exists $param{append_log} or $param{append_log};
917 writebug($data->{bug_num},$data);
919 print {$transcript} "$action\n";
920 __end_control(%info);
921 if (exists $param{submitter}) {
922 set_submitter(bug => $param{bug},
923 submitter => $param{submitter},
925 keys %common_options,
926 keys %append_action_options)
929 # clear the fixed revisions
930 if ($param{clear_fixed}) {
931 set_fixed(fixed => [],
935 keys %common_options,
936 keys %append_action_options),
941 my %submitter_notified;
942 my $requester_notified = 0;
943 my $orig_report_set = 0;
944 for my $data (@data) {
945 if (exists $data->{done} and
946 defined $data->{done} and
947 length $data->{done}) {
948 print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
949 __end_control(%info);
953 for my $data (@data) {
954 my $old_data = dclone($data);
955 my $hash = get_hashname($data->{bug_num});
956 my $report_fh = IO::File->new("db-h/$hash/$data->{bug_num}.report",'r') or
957 die "Unable to open original report db-h/$hash/$data->{bug_num}.report for reading: $!";
961 $orig_report= <$report_fh>;
964 if (not $orig_report_set and defined $orig_report and
965 length $orig_report and
966 exists $param{original_report}){
967 ${$param{original_report}} = $orig_report;
968 $orig_report_set = 1;
971 $action = "Marked $config{bug} as done";
973 # set done to the requester
974 $data->{done} = exists $param{done}?$param{done}:$param{requester};
975 append_action_to_log(bug => $data->{bug_num},
978 old_data => $old_data,
980 __return_append_to_log_options(
985 if not exists $param{append_log} or $param{append_log};
986 writebug($data->{bug_num},$data);
987 print {$transcript} "$action\n";
988 # get the original report
989 if ($param{notify_submitter}) {
990 my $submitter_message;
991 if(not exists $submitter_notified{$data->{originator}}) {
993 create_mime_message([default_headers(queue_file => $param{request_nn},
995 msgid => $param{request_msgid},
996 msgtype => 'notifdone',
997 pr_msg => 'they-closed',
999 [To => $data->{submitter},
1000 Subject => "$config{ubug}#$data->{bug_num} ".
1001 "closed by $param{requester} ($param{request_subject})",
1005 __message_body_template('mail/process_your_bug_done',
1007 replyto => (exists $param{request_replyto} ?
1008 $param{request_replyto} :
1009 $param{requester} || 'Unknown'),
1010 markedby => $param{requester},
1011 subject => $param{request_subject},
1012 messageid => $param{request_msgid},
1015 [join('',make_list($param{message})),$orig_report]
1017 send_mail_message(message => $submitter_message,
1018 recipients => $old_data->{submitter},
1020 $submitter_notified{$data->{originator}} = $submitter_message;
1023 $submitter_message = $submitter_notified{$data->{originator}};
1025 append_action_to_log(bug => $data->{bug_num},
1026 action => "Notification sent",
1028 request_addr => $data->{originator},
1029 desc => "$config{bug} acknowledged by developer.",
1030 recips => [$data->{originator}],
1031 message => $submitter_message,
1036 __end_control(%info);
1037 if (exists $param{fixed}) {
1038 set_fixed(fixed => $param{fixed},
1042 keys %common_options,
1043 keys %append_action_options
1051 =head2 set_submitter
1054 set_submitter(bug => $ref,
1055 transcript => $transcript,
1056 ($dl > 0 ? (debug => $transcript):()),
1057 requester => $header{from},
1058 request_addr => $controlrequestaddr,
1060 affected_packages => \%affected_packages,
1061 recipients => \%recipients,
1062 submitter => $new_submitter,
1063 notify_submitter => 1,
1068 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1071 Sets the submitter of a bug. If notify_submitter is true (the
1072 default), notifies the old submitter of a bug on changes
1077 my %param = validate_with(params => \@_,
1078 spec => {bug => {type => SCALAR,
1081 # specific options here
1082 submitter => {type => SCALAR,
1084 notify_submitter => {type => BOOLEAN,
1088 %append_action_options,
1091 if (not Mail::RFC822::Address::valid($param{submitter})) {
1092 die "New submitter address $param{submitter} is not a valid e-mail address";
1095 __begin_control(%param,
1096 command => 'submitter'
1098 my ($debug,$transcript) =
1099 @info{qw(debug transcript)};
1100 my @data = @{$info{data}};
1101 my @bugs = @{$info{bugs}};
1103 # here we only concern ourselves with the first of the merged bugs
1104 for my $data ($data[0]) {
1105 my $notify_old_submitter = 0;
1106 my $old_data = dclone($data);
1107 print {$debug} "Going to change bug submitter\n";
1108 if (((not defined $param{submitter} or not length $param{submitter}) and
1109 (not defined $data->{originator} or not length $data->{originator})) or
1110 (defined $param{submitter} and defined $data->{originator} and
1111 $param{submitter} eq $data->{originator})) {
1112 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
1113 unless __internal_request();
1117 if (defined $data->{originator} and length($data->{originator})) {
1118 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
1119 $notify_old_submitter = 1;
1122 $action= "Set $config{bug} submitter to '$param{submitter}'.";
1124 $data->{originator} = $param{submitter};
1126 append_action_to_log(bug => $data->{bug_num},
1127 command => 'submitter',
1129 old_data => $old_data,
1131 __return_append_to_log_options(
1136 if not exists $param{append_log} or $param{append_log};
1137 writebug($data->{bug_num},$data);
1138 print {$transcript} "$action\n";
1139 # notify old submitter
1140 if ($notify_old_submitter and $param{notify_submitter}) {
1141 send_mail_message(message =>
1142 create_mime_message([default_headers(queue_file => $param{request_nn},
1144 msgid => $param{request_msgid},
1146 pr_msg => 'submitter-changed',
1148 [To => $old_data->{submitter},
1149 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
1153 __message_body_template('mail/submitter_changed',
1154 {old_data => $old_data,
1156 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
1160 recipients => $old_data->{submitter},
1164 __end_control(%info);
1169 =head2 set_forwarded
1172 set_forwarded(bug => $ref,
1173 transcript => $transcript,
1174 ($dl > 0 ? (debug => $transcript):()),
1175 requester => $header{from},
1176 request_addr => $controlrequestaddr,
1178 affected_packages => \%affected_packages,
1179 recipients => \%recipients,
1180 forwarded => $forward_to,
1185 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1188 Sets the location to which a bug is forwarded. Given an undef
1189 forwarded, unsets forwarded.
1195 my %param = validate_with(params => \@_,
1196 spec => {bug => {type => SCALAR,
1199 # specific options here
1200 forwarded => {type => SCALAR|UNDEF,
1203 %append_action_options,
1206 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1207 die "Non-printable characters are not allowed in the forwarded field";
1209 $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
1211 __begin_control(%param,
1212 command => 'forwarded'
1214 my ($debug,$transcript) =
1215 @info{qw(debug transcript)};
1216 my @data = @{$info{data}};
1217 my @bugs = @{$info{bugs}};
1219 for my $data (@data) {
1220 my $old_data = dclone($data);
1221 print {$debug} "Going to change bug forwarded\n";
1222 if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
1223 (not defined $param{forwarded} and
1224 defined $data->{forwarded} and not length $data->{forwarded})) {
1225 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1226 unless __internal_request();
1230 if (not defined $param{forwarded}) {
1231 $action= "Unset $config{bug} forwarded-to-address";
1233 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1234 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1237 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1239 $data->{forwarded} = $param{forwarded};
1241 append_action_to_log(bug => $data->{bug_num},
1242 command => 'forwarded',
1244 old_data => $old_data,
1246 __return_append_to_log_options(
1251 if not exists $param{append_log} or $param{append_log};
1252 writebug($data->{bug_num},$data);
1253 print {$transcript} "$action\n";
1255 __end_control(%info);
1264 set_title(bug => $ref,
1265 transcript => $transcript,
1266 ($dl > 0 ? (debug => $transcript):()),
1267 requester => $header{from},
1268 request_addr => $controlrequestaddr,
1270 affected_packages => \%affected_packages,
1271 recipients => \%recipients,
1272 title => $new_title,
1277 print {$transcript} "Failed to set the title of $ref: $@";
1280 Sets the title of a specific bug
1286 my %param = validate_with(params => \@_,
1287 spec => {bug => {type => SCALAR,
1290 # specific options here
1291 title => {type => SCALAR,
1294 %append_action_options,
1297 if ($param{title} =~ /[^[:print:]]/) {
1298 die "Non-printable characters are not allowed in bug titles";
1301 my %info = __begin_control(%param,
1304 my ($debug,$transcript) =
1305 @info{qw(debug transcript)};
1306 my @data = @{$info{data}};
1307 my @bugs = @{$info{bugs}};
1309 for my $data (@data) {
1310 my $old_data = dclone($data);
1311 print {$debug} "Going to change bug title\n";
1312 if (defined $data->{subject} and length($data->{subject}) and
1313 $data->{subject} eq $param{title}) {
1314 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1315 unless __internal_request();
1319 if (defined $data->{subject} and length($data->{subject})) {
1320 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1322 $action= "Set $config{bug} title to '$param{title}'.";
1324 $data->{subject} = $param{title};
1326 append_action_to_log(bug => $data->{bug_num},
1329 old_data => $old_data,
1331 __return_append_to_log_options(
1336 if not exists $param{append_log} or $param{append_log};
1337 writebug($data->{bug_num},$data);
1338 print {$transcript} "$action\n";
1340 __end_control(%info);
1347 set_package(bug => $ref,
1348 transcript => $transcript,
1349 ($dl > 0 ? (debug => $transcript):()),
1350 requester => $header{from},
1351 request_addr => $controlrequestaddr,
1353 affected_packages => \%affected_packages,
1354 recipients => \%recipients,
1355 package => $new_package,
1361 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1364 Indicates that a bug is in a particular package. If is_source is true,
1365 indicates that the package is a source package. [Internally, this
1366 causes src: to be prepended to the package name.]
1368 The default for is_source is 0. As a special case, if the package
1369 starts with 'src:', it is assumed to be a source package and is_source
1372 The package option must match the package_name_re regex.
1377 my %param = validate_with(params => \@_,
1378 spec => {bug => {type => SCALAR,
1381 # specific options here
1382 package => {type => SCALAR|ARRAYREF,
1384 is_source => {type => BOOLEAN,
1388 %append_action_options,
1391 my @new_packages = map {splitpackages($_)} make_list($param{package});
1392 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1393 croak "Invalid package name '".
1394 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1397 my %info = __begin_control(%param,
1398 command => 'package',
1400 my ($debug,$transcript) =
1401 @info{qw(debug transcript)};
1402 my @data = @{$info{data}};
1403 my @bugs = @{$info{bugs}};
1404 # clean up the new package
1408 ($temp =~ s/^src:// or
1409 $param{is_source}) ? 'src:'.$temp:$temp;
1413 my $package_reassigned = 0;
1414 for my $data (@data) {
1415 my $old_data = dclone($data);
1416 print {$debug} "Going to change assigned package\n";
1417 if (defined $data->{package} and length($data->{package}) and
1418 $data->{package} eq $new_package) {
1419 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1420 unless __internal_request();
1424 if (defined $data->{package} and length($data->{package})) {
1425 $package_reassigned = 1;
1426 $action= "$config{bug} reassigned from package '$data->{package}'".
1427 " to '$new_package'.";
1429 $action= "$config{bug} assigned to package '$new_package'.";
1431 $data->{package} = $new_package;
1433 append_action_to_log(bug => $data->{bug_num},
1434 command => 'package',
1436 old_data => $old_data,
1438 __return_append_to_log_options(
1443 if not exists $param{append_log} or $param{append_log};
1444 writebug($data->{bug_num},$data);
1445 print {$transcript} "$action\n";
1447 __end_control(%info);
1448 # Only clear the fixed/found versions if the package has been
1450 if ($package_reassigned) {
1451 my @params_for_found_fixed =
1452 map {exists $param{$_}?($_,$param{$_}):()}
1454 keys %common_options,
1455 keys %append_action_options,
1457 set_found(found => [],
1458 @params_for_found_fixed,
1460 set_fixed(fixed => [],
1461 @params_for_found_fixed,
1469 set_found(bug => $ref,
1470 transcript => $transcript,
1471 ($dl > 0 ? (debug => $transcript):()),
1472 requester => $header{from},
1473 request_addr => $controlrequestaddr,
1475 affected_packages => \%affected_packages,
1476 recipients => \%recipients,
1483 print {$transcript} "Failed to set found on $ref: $@";
1487 Sets, adds, or removes the specified found versions of a package
1489 If the version list is empty, and the bug is currently not "done",
1490 causes the done field to be cleared.
1492 If any of the versions added to found are greater than any version in
1493 which the bug is fixed (or when the bug is found and there are no
1494 fixed versions) the done field is cleared.
1499 my %param = validate_with(params => \@_,
1500 spec => {bug => {type => SCALAR,
1503 # specific options here
1504 found => {type => SCALAR|ARRAYREF,
1507 add => {type => BOOLEAN,
1510 remove => {type => BOOLEAN,
1514 %append_action_options,
1517 if ($param{add} and $param{remove}) {
1518 croak "It's nonsensical to add and remove the same versions";
1522 __begin_control(%param,
1525 my ($debug,$transcript) =
1526 @info{qw(debug transcript)};
1527 my @data = @{$info{data}};
1528 my @bugs = @{$info{bugs}};
1530 for my $version (make_list($param{found})) {
1531 next unless defined $version;
1532 $versions{$version} =
1533 [make_source_versions(package => [splitpackages($data[0]{package})],
1534 warnings => $transcript,
1537 versions => $version,
1540 # This is really ugly, but it's what we have to do
1541 if (not @{$versions{$version}}) {
1542 print {$transcript} "Unable to make a source version for version '$version'\n";
1545 if (not keys %versions and ($param{remove} or $param{add})) {
1546 if ($param{remove}) {
1547 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1550 print {$transcript} "Requested to add no versions; doing nothing.\n";
1552 __end_control(%info);
1555 # first things first, make the versions fully qualified source
1557 for my $data (@data) {
1558 # The 'done' field gets a bit weird with version tracking,
1559 # because a bug may be closed by multiple people in different
1560 # branches. Until we have something more flexible, we set it
1561 # every time a bug is fixed, and clear it when a bug is found
1562 # in a version greater than any version in which the bug is
1563 # fixed or when a bug is found and there is no fixed version
1564 my $action = 'Did not alter found versions';
1565 my %found_added = ();
1566 my %found_removed = ();
1567 my %fixed_removed = ();
1569 my $old_data = dclone($data);
1570 if (not $param{add} and not $param{remove}) {
1571 $found_removed{$_} = 1 for @{$data->{found_versions}};
1572 $data->{found_versions} = [];
1575 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1577 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1578 for my $version (keys %versions) {
1580 my @svers = @{$versions{$version}};
1584 for my $sver (@svers) {
1585 if (not exists $found_versions{$sver}) {
1586 $found_versions{$sver} = 1;
1587 $found_added{$sver} = 1;
1589 # if the found we are adding matches any fixed
1590 # versions, remove them
1591 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1592 delete $fixed_versions{$_} for @temp;
1593 $fixed_removed{$_} = 1 for @temp;
1596 # We only care about reopening the bug if the bug is
1598 if (defined $data->{done} and length $data->{done}) {
1599 my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
1601 # determine if we need to reopen
1602 my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
1603 keys %fixed_versions);
1604 if (not @fixed_order or
1605 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1611 elsif ($param{remove}) {
1612 # in the case of removal, we only concern ourself with
1613 # the version passed, not the source version it maps
1615 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1616 delete $found_versions{$_} for @temp;
1617 $found_removed{$_} = 1 for @temp;
1620 # set the keys to exactly these values
1621 my @svers = @{$versions{$version}};
1625 for my $sver (@svers) {
1626 if (not exists $found_versions{$sver}) {
1627 $found_versions{$sver} = 1;
1628 if (exists $found_removed{$sver}) {
1629 delete $found_removed{$sver};
1632 $found_added{$sver} = 1;
1639 $data->{found_versions} = [keys %found_versions];
1640 $data->{fixed_versions} = [keys %fixed_versions];
1643 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1644 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1645 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1646 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1647 $action = ucfirst(join ('; ',@changed)) if @changed;
1649 $action .= " and reopened"
1651 if (not $reopened and not @changed) {
1652 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1653 unless __internal_request();
1657 append_action_to_log(bug => $data->{bug_num},
1660 old_data => $old_data,
1662 __return_append_to_log_options(
1667 if not exists $param{append_log} or $param{append_log};
1668 writebug($data->{bug_num},$data);
1669 print {$transcript} "$action\n";
1671 __end_control(%info);
1677 set_fixed(bug => $ref,
1678 transcript => $transcript,
1679 ($dl > 0 ? (debug => $transcript):()),
1680 requester => $header{from},
1681 request_addr => $controlrequestaddr,
1683 affected_packages => \%affected_packages,
1684 recipients => \%recipients,
1692 print {$transcript} "Failed to set fixed on $ref: $@";
1696 Sets, adds, or removes the specified fixed versions of a package
1698 If the fixed versions are empty (or end up being empty after this
1699 call) or the greatest fixed version is less than the greatest found
1700 version and the reopen option is true, the bug is reopened.
1702 This function is also called by the reopen function, which causes all
1703 of the fixed versions to be cleared.
1708 my %param = validate_with(params => \@_,
1709 spec => {bug => {type => SCALAR,
1712 # specific options here
1713 fixed => {type => SCALAR|ARRAYREF,
1716 add => {type => BOOLEAN,
1719 remove => {type => BOOLEAN,
1722 reopen => {type => BOOLEAN,
1726 %append_action_options,
1729 if ($param{add} and $param{remove}) {
1730 croak "It's nonsensical to add and remove the same versions";
1733 __begin_control(%param,
1736 my ($debug,$transcript) =
1737 @info{qw(debug transcript)};
1738 my @data = @{$info{data}};
1739 my @bugs = @{$info{bugs}};
1741 for my $version (make_list($param{fixed})) {
1742 next unless defined $version;
1743 $versions{$version} =
1744 [make_source_versions(package => [splitpackages($data[0]{package})],
1745 warnings => $transcript,
1748 versions => $version,
1751 # This is really ugly, but it's what we have to do
1752 if (not @{$versions{$version}}) {
1753 print {$transcript} "Unable to make a source version for version '$version'\n";
1756 if (not keys %versions and ($param{remove} or $param{add})) {
1757 if ($param{remove}) {
1758 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1761 print {$transcript} "Requested to add no versions; doing nothing.\n";
1763 __end_control(%info);
1766 # first things first, make the versions fully qualified source
1768 for my $data (@data) {
1769 my $old_data = dclone($data);
1770 # The 'done' field gets a bit weird with version tracking,
1771 # because a bug may be closed by multiple people in different
1772 # branches. Until we have something more flexible, we set it
1773 # every time a bug is fixed, and clear it when a bug is found
1774 # in a version greater than any version in which the bug is
1775 # fixed or when a bug is found and there is no fixed version
1776 my $action = 'Did not alter fixed versions';
1777 my %found_added = ();
1778 my %found_removed = ();
1779 my %fixed_added = ();
1780 my %fixed_removed = ();
1782 if (not $param{add} and not $param{remove}) {
1783 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1784 $data->{fixed_versions} = [];
1787 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1789 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1790 for my $version (keys %versions) {
1792 my @svers = @{$versions{$version}};
1796 for my $sver (@svers) {
1797 if (not exists $fixed_versions{$sver}) {
1798 $fixed_versions{$sver} = 1;
1799 $fixed_added{$sver} = 1;
1803 elsif ($param{remove}) {
1804 # in the case of removal, we only concern ourself with
1805 # the version passed, not the source version it maps
1807 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1808 delete $fixed_versions{$_} for @temp;
1809 $fixed_removed{$_} = 1 for @temp;
1812 # set the keys to exactly these values
1813 my @svers = @{$versions{$version}};
1817 for my $sver (@svers) {
1818 if (not exists $fixed_versions{$sver}) {
1819 $fixed_versions{$sver} = 1;
1820 if (exists $fixed_removed{$sver}) {
1821 delete $fixed_removed{$sver};
1824 $fixed_added{$sver} = 1;
1831 $data->{found_versions} = [keys %found_versions];
1832 $data->{fixed_versions} = [keys %fixed_versions];
1834 # If we're supposed to consider reopening, reopen if the
1835 # fixed versions are empty or the greatest found version
1836 # is greater than the greatest fixed version
1837 if ($param{reopen} and defined $data->{done}
1838 and length $data->{done}) {
1839 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1840 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1841 # determine if we need to reopen
1842 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1843 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1844 if (not @fixed_order or
1845 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1852 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1853 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1854 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1855 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1856 $action = ucfirst(join ('; ',@changed)) if @changed;
1858 $action .= " and reopened"
1860 if (not $reopened and not @changed) {
1861 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1862 unless __internal_request();
1866 append_action_to_log(bug => $data->{bug_num},
1869 old_data => $old_data,
1871 __return_append_to_log_options(
1876 if not exists $param{append_log} or $param{append_log};
1877 writebug($data->{bug_num},$data);
1878 print {$transcript} "$action\n";
1880 __end_control(%info);
1887 set_merged(bug => $ref,
1888 transcript => $transcript,
1889 ($dl > 0 ? (debug => $transcript):()),
1890 requester => $header{from},
1891 request_addr => $controlrequestaddr,
1893 affected_packages => \%affected_packages,
1894 recipients => \%recipients,
1895 merge_with => 12345,
1898 allow_reassign => 1,
1899 reassign_same_source_only => 1,
1904 print {$transcript} "Failed to set merged on $ref: $@";
1908 Sets, adds, or removes the specified merged bugs of a bug
1910 By default, requires
1915 my %param = validate_with(params => \@_,
1916 spec => {bug => {type => SCALAR,
1919 # specific options here
1920 merge_with => {type => ARRAYREF|SCALAR,
1923 remove => {type => BOOLEAN,
1926 force => {type => BOOLEAN,
1929 masterbug => {type => BOOLEAN,
1932 allow_reassign => {type => BOOLEAN,
1935 reassign_different_sources => {type => BOOLEAN,
1939 %append_action_options,
1942 my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1944 @merging{@merging} = (1) x @merging;
1945 if (grep {$_ !~ /^\d+$/} @merging) {
1946 croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1948 $param{locks} = {} if not exists $param{locks};
1950 __begin_control(%param,
1953 my ($debug,$transcript) =
1954 @info{qw(debug transcript)};
1955 if (not @merging and exists $param{merge_with}) {
1956 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1957 __end_control(%info);
1960 my @data = @{$info{data}};
1961 my @bugs = @{$info{bugs}};
1964 for my $data (@data) {
1965 $data{$data->{bug_num}} = $data;
1966 my @merged_bugs = split / /, $data->{mergedwith};
1967 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1971 if (not exists $param{merge_with}) {
1972 my $ok_to_unmerge = 1;
1973 delete $merged_bugs{$param{bug}};
1974 if (not keys %merged_bugs) {
1975 print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1976 __end_control(%info);
1979 my $action = "Disconnected #$param{bug} from all other report(s).";
1980 for my $data (@data) {
1981 my $old_data = dclone($data);
1982 if ($data->{bug_num} == $param{bug}) {
1983 $data->{mergedwith} = '';
1986 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
1989 append_action_to_log(bug => $data->{bug_num},
1992 old_data => $old_data,
1994 __return_append_to_log_options(%param,
1998 if not exists $param{append_log} or $param{append_log};
1999 writebug($data->{bug_num},$data);
2001 print {$transcript} "$action\n";
2002 __end_control(%info);
2005 # lock and load all of the bugs we need
2006 my @bugs_to_load = keys %merging;
2009 my ($data,$n_locks) =
2010 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2012 locks => $param{locks},
2015 $new_locks += $n_locks;
2017 @data = values %data;
2018 if (not __check_limit(data => [@data],
2019 exists $param{limit}?(limit => $param{limit}):(),
2020 transcript => $transcript,
2022 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2024 for my $data (@data) {
2025 $data{$data->{bug_num}} = $data;
2026 $merged_bugs{$data->{bug_num}} = 1;
2027 my @merged_bugs = split / /, $data->{mergedwith};
2028 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2029 if (exists $param{affected_bugs}) {
2030 $param{affected_bugs}{$data->{bug_num}} = 1;
2033 __handle_affected_packages(%param,data => [@data]);
2034 my %bug_info_shown; # which bugs have had information shown
2035 $bug_info_shown{$param{bug}} = 1;
2036 add_recipients(data => [@data],
2037 recipients => $param{recipients},
2038 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2040 (__internal_request()?(transcript => $transcript):()),
2043 # Figure out what the ideal state is for the bug,
2044 my ($merge_status,$bugs_to_merge) =
2045 __calculate_merge_status(\@data,\%data,$param{bug});
2046 # find out if we actually have any bugs to merge
2047 if (not $bugs_to_merge) {
2048 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2049 for (1..$new_locks) {
2050 unfilelock($param{locks});
2053 __end_control(%info);
2056 # see what changes need to be made to merge the bugs
2057 # check to make sure that the set of changes we need to make is allowed
2058 my ($disallowed_changes,$changes) =
2059 __calculate_merge_changes(\@data,$merge_status,\%param);
2060 # at this point, stop if there are disallowed changes, otherwise
2061 # make the allowed changes, and then reread the bugs in question
2062 # to get the new data, then recaculate the merges; repeat
2063 # reloading and recalculating until we try too many times or there
2064 # are no changes to make.
2067 # we will allow at most 4 times through this; more than 1
2068 # shouldn't really happen.
2070 while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2071 if ($attempts > 1) {
2072 print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2074 if (@{$disallowed_changes}) {
2075 # figure out the problems
2076 print {$transcript} "Unable to merge bugs because:\n";
2077 for my $change (@{$disallowed_changes}) {
2078 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{orig_value}' not '$change->{text_value}'\n";
2080 if ($attempts > 0) {
2081 croak "Some bugs were altered while attempting to merge";
2084 croak "Did not alter merged bugs";
2087 my ($change_bug) = keys %{$changes};
2088 $bug_changed{$change_bug}++;
2089 print {$transcript} __bug_info($data{$change_bug}) if
2090 $param{show_bug_info} and not __internal_request(1);
2091 $bug_info_shown{$change_bug} = 1;
2092 __allow_relocking($param{locks},[keys %data]);
2093 for my $change (@{$changes->{$change_bug}}) {
2094 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2095 my %target_blockedby;
2096 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2097 my %unhandled_targets = %target_blockedby;
2098 my @blocks_to_remove;
2099 for my $key (split / /,$change->{orig_value}) {
2100 delete $unhandled_targets{$key};
2101 next if exists $target_blockedby{$key};
2102 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2103 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2106 keys %common_options,
2107 keys %append_action_options),
2110 for my $key (keys %unhandled_targets) {
2111 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2112 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2115 keys %common_options,
2116 keys %append_action_options),
2121 $change->{function}->(bug => $change->{bug},
2122 $change->{key}, $change->{func_value},
2123 exists $change->{options}?@{$change->{options}}:(),
2125 keys %common_options,
2126 keys %append_action_options),
2130 __disallow_relocking($param{locks});
2131 my ($data,$n_locks) =
2132 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2134 locks => $param{locks},
2138 $new_locks += $n_locks;
2141 @data = values %data;
2142 ($merge_status,$bugs_to_merge) =
2143 __calculate_merge_status(\@data,\%data,$param{bug});
2144 ($disallowed_changes,$changes) =
2145 __calculate_merge_changes(\@data,$merge_status,\%param);
2146 $attempts = max(values %bug_changed);
2148 if ($param{show_bug_info} and not __internal_request(1)) {
2149 for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2150 next if $bug_info_shown{$data->{bug_num}};
2151 print {$transcript} __bug_info($data);
2154 if (keys %{$changes} or @{$disallowed_changes}) {
2155 print {$transcript} "Unable to modify bugs so that they could be merged\n";
2156 for (1..$new_locks) {
2157 unfilelock($param{locks});
2160 __end_control(%info);
2164 # finally, we can merge the bugs
2165 my $action = "Merged ".join(' ',sort keys %merged_bugs);
2166 for my $data (@data) {
2167 my $old_data = dclone($data);
2168 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2170 append_action_to_log(bug => $data->{bug_num},
2173 old_data => $old_data,
2175 __return_append_to_log_options(%param,
2179 if not exists $param{append_log} or $param{append_log};
2180 writebug($data->{bug_num},$data);
2182 print {$transcript} "$action\n";
2183 # unlock the extra locks that we got earlier
2184 for (1..$new_locks) {
2185 unfilelock($param{locks});
2188 __end_control(%info);
2191 sub __allow_relocking{
2192 my ($locks,$bugs) = @_;
2194 for my $bug (@{$bugs}) {
2195 my @lockfiles = grep {m{/\Q$bug\E$}} keys %{$locks->{locks}};
2196 next unless @lockfiles;
2197 $locks->{relockable}{$lockfiles[0]} = 0;
2201 sub __disallow_relocking{
2203 delete $locks->{relockable};
2206 sub __lock_and_load_merged_bugs{
2208 validate_with(params => \@_,
2210 {bugs_to_load => {type => ARRAYREF,
2211 default => sub {[]},
2213 data => {type => HASHREF|ARRAYREF,
2215 locks => {type => HASHREF,
2216 default => sub {{};},
2218 reload_all => {type => BOOLEAN,
2221 debug => {type => HANDLE,
2227 if (ref($param{data}) eq 'ARRAY') {
2228 for my $data (@{$param{data}}) {
2229 $data{$data->{bug_num}} = dclone($data);
2233 %data = %{dclone($param{data})};
2235 my @bugs_to_load = @{$param{bugs_to_load}};
2236 if ($param{reload_all}) {
2237 push @bugs_to_load, keys %data;
2240 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2241 @bugs_to_load = keys %temp;
2242 my %loaded_this_time;
2244 while ($bug_to_load = shift @bugs_to_load) {
2245 if (not $param{reload_all}) {
2246 next if exists $data{$bug_to_load};
2249 next if $loaded_this_time{$bug_to_load};
2252 if ($param{reload_all}) {
2253 if (exists $data{$bug_to_load}) {
2258 read_bug(bug => $bug_to_load,
2260 locks => $param{locks},
2262 die "Unable to load bug $bug_to_load";
2263 print {$param{debug}} "read bug $bug_to_load\n";
2264 $data{$data->{bug_num}} = $data;
2265 $new_locks += $lock_bug;
2266 $loaded_this_time{$data->{bug_num}} = 1;
2268 grep {not exists $data{$_}}
2269 split / /,$data->{mergedwith};
2271 return (\%data,$new_locks);
2275 sub __calculate_merge_status{
2276 my ($data_a,$data_h,$master_bug,$merge) = @_;
2279 my $bugs_to_merge = 0;
2280 for my $data (@{$data_a}) {
2281 # check to see if this bug is unmerged in the set
2282 if (not length $data->{mergedwith} or
2283 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2284 $merged_bugs{$data->{bug_num}} = 1;
2287 # the master_bug is the bug that every other bug is made to
2288 # look like. However, if merge is set, tags, fixed and found
2290 if ($data->{bug_num} == $master_bug) {
2291 for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2292 $merge_status{$_} = $data->{$_}
2296 next unless $data->{bug_num} == $master_bug;
2298 $merge_status{tag} = {} if not exists $merge_status{tag};
2299 for my $tag (split /\s+/, $data->{keywords}) {
2300 $merge_status{tag}{$tag} = 1;
2302 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2303 for (qw(fixed found)) {
2304 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2307 return (\%merge_status,$bugs_to_merge);
2312 sub __calculate_merge_changes{
2313 my ($datas,$merge_status,$param) = @_;
2315 my @disallowed_changes;
2316 for my $data (@{$datas}) {
2317 # things that can be forced
2319 # * func is the function to set the new value
2321 # * key is the key of the function to set the value,
2323 # * modify_value is a function which is called to modify the new
2324 # value so that the function will accept it
2326 # * options is an ARRAYREF of options to pass to the function
2328 # * allowed is a BOOLEAN which controls whether this setting
2329 # is allowed to be different by default.
2330 my %force_functions =
2331 (forwarded => {func => \&set_forwarded,
2335 severity => {func => \&set_severity,
2339 blocks => {func => \&set_blocks,
2340 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2344 blockedby => {func => \&set_blocks,
2345 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2349 done => {func => \&set_done,
2353 owner => {func => \&owner,
2357 summary => {func => \&summary,
2361 affects => {func => \&affects,
2365 package => {func => \&set_package,
2369 keywords => {func => \&set_tag,
2371 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2374 fixed_versions => {func => \&set_fixed,
2376 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2379 found_versions => {func => \&set_found,
2381 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2385 for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2386 # if the ideal bug already has the field set properly, we
2388 if ($field eq 'keywords'){
2389 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2390 join(' ',sort keys %{$merge_status->{tag}});
2392 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2393 next if join(' ', sort @{$data->{$field}}) eq
2394 join(' ',sort keys %{$merge_status->{$field}});
2396 elsif ($merge_status->{$field} eq $data->{$field}) {
2401 bug => $data->{bug_num},
2402 orig_value => $data->{$field},
2404 (exists $force_functions{$field}{modify_value} ?
2405 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2406 $merge_status->{$field}),
2407 value => $merge_status->{$field},
2408 function => $force_functions{$field}{func},
2409 key => $force_functions{$field}{key},
2410 options => $force_functions{$field}{options},
2411 allowed => exists $force_functions{$field}{allowed} ? 0 : $force_functions{$field}{allowed},
2413 $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
2414 if ($param->{force}) {
2415 if ($field ne 'package') {
2416 push @{$changes{$data->{bug_num}}},$change;
2419 if ($param->{allow_reassign}) {
2420 if ($param->{reassign_different_sources}) {
2421 push @{$changes{$data->{bug_num}}},$change;
2424 # allow reassigning if binary_to_source returns at
2425 # least one of the same source packages
2426 my @merge_status_source =
2427 binary_to_source(package => $merge_status->{package},
2430 my @other_bug_source =
2431 binary_to_source(package => $data->{package},
2434 my %merge_status_sources;
2435 @merge_status_sources{@merge_status_source} =
2436 (1) x @merge_status_source;
2437 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2438 push @{$changes{$data->{bug_num}}},$change;
2443 push @disallowed_changes,$change;
2445 # blocks and blocked by are weird; we have to go through and
2446 # set blocks to the other half of the merged bugs
2448 return (\@disallowed_changes,\%changes);
2454 affects(bug => $ref,
2455 transcript => $transcript,
2456 ($dl > 0 ? (debug => $transcript):()),
2457 requester => $header{from},
2458 request_addr => $controlrequestaddr,
2460 affected_packages => \%affected_packages,
2461 recipients => \%recipients,
2469 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2472 This marks a bug as affecting packages which the bug is not actually
2473 in. This should only be used in cases where fixing the bug instantly
2474 resolves the problem in the other packages.
2476 By default, the packages are set to the list of packages passed.
2477 However, if you pass add => 1 or remove => 1, the list of packages
2478 passed are added or removed from the affects list, respectively.
2483 my %param = validate_with(params => \@_,
2484 spec => {bug => {type => SCALAR,
2487 # specific options here
2488 package => {type => SCALAR|ARRAYREF|UNDEF,
2491 add => {type => BOOLEAN,
2494 remove => {type => BOOLEAN,
2498 %append_action_options,
2501 if ($param{add} and $param{remove}) {
2502 croak "Asking to both add and remove affects is nonsensical";
2504 if (not defined $param{package}) {
2505 $param{package} = [];
2508 __begin_control(%param,
2509 command => 'affects'
2511 my ($debug,$transcript) =
2512 @info{qw(debug transcript)};
2513 my @data = @{$info{data}};
2514 my @bugs = @{$info{bugs}};
2516 for my $data (@data) {
2518 print {$debug} "Going to change affects\n";
2519 my @packages = splitpackages($data->{affects});
2521 @packages{@packages} = (1) x @packages;
2524 for my $package (make_list($param{package})) {
2525 next unless defined $package and length $package;
2526 if (not $packages{$package}) {
2527 $packages{$package} = 1;
2528 push @added,$package;
2532 $action = "Added indication that $data->{bug_num} affects ".
2533 english_join(\@added);
2536 elsif ($param{remove}) {
2538 for my $package (make_list($param{package})) {
2539 if ($packages{$package}) {
2540 next unless defined $package and length $package;
2541 delete $packages{$package};
2542 push @removed,$package;
2545 $action = "Removed indication that $data->{bug_num} affects " .
2546 english_join(\@removed);
2549 my %added_packages = ();
2550 my %removed_packages = %packages;
2552 for my $package (make_list($param{package})) {
2553 next unless defined $package and length $package;
2554 $packages{$package} = 1;
2555 delete $removed_packages{$package};
2556 $added_packages{$package} = 1;
2558 if (keys %removed_packages) {
2559 $action = "Removed indication that $data->{bug_num} affects ".
2560 english_join([keys %removed_packages]);
2561 $action .= "\n" if keys %added_packages;
2563 if (keys %added_packages) {
2564 $action .= "Added indication that $data->{bug_num} affects " .
2565 english_join([keys %added_packages]);
2568 if (not length $action) {
2569 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
2570 unless __internal_request();
2573 my $old_data = dclone($data);
2574 $data->{affects} = join(',',keys %packages);
2575 append_action_to_log(bug => $data->{bug_num},
2577 command => 'affects',
2579 old_data => $old_data,
2580 __return_append_to_log_options(
2585 if not exists $param{append_log} or $param{append_log};
2586 writebug($data->{bug_num},$data);
2587 print {$transcript} "$action\n";
2589 __end_control(%info);
2593 =head1 SUMMARY FUNCTIONS
2598 summary(bug => $ref,
2599 transcript => $transcript,
2600 ($dl > 0 ? (debug => $transcript):()),
2601 requester => $header{from},
2602 request_addr => $controlrequestaddr,
2604 affected_packages => \%affected_packages,
2605 recipients => \%recipients,
2611 print {$transcript} "Failed to mark $ref with summary foo: $@";
2614 Handles all setting of summary fields
2616 If summary is undef, unsets the summary
2618 If summary is 0, sets the summary to the first paragraph contained in
2621 If summary is a positive integer, sets the summary to the message specified.
2623 Otherwise, sets summary to the value passed.
2629 my %param = validate_with(params => \@_,
2630 spec => {bug => {type => SCALAR,
2633 # specific options here
2634 summary => {type => SCALAR|UNDEF,
2638 %append_action_options,
2641 # croak "summary must be numeric or undef" if
2642 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2644 __begin_control(%param,
2645 command => 'summary'
2647 my ($debug,$transcript) =
2648 @info{qw(debug transcript)};
2649 my @data = @{$info{data}};
2650 my @bugs = @{$info{bugs}};
2651 # figure out the log that we're going to use
2653 my $summary_msg = '';
2655 if (not defined $param{summary}) {
2657 print {$debug} "Removing summary fields\n";
2658 $action = 'Removed summary';
2660 elsif ($param{summary} =~ /^\d+$/) {
2662 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2663 if ($param{summary} == 0) {
2664 $log = $param{message};
2665 $summary_msg = @records + 1;
2668 if (($param{summary} - 1 ) > $#records) {
2669 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2671 my $record = $records[($param{summary} - 1 )];
2672 if ($record->{type} !~ /incoming-recv|recips/) {
2673 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2675 $summary_msg = $param{summary};
2676 $log = [$record->{text}];
2678 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2679 my $body = $p_o->{body};
2680 my $in_pseudoheaders = 0;
2682 # walk through body until we get non-blank lines
2683 for my $line (@{$body}) {
2684 if ($line =~ /^\s*$/) {
2685 if (length $paragraph) {
2686 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2692 $in_pseudoheaders = 0;
2695 # skip a paragraph if it looks like it's control or
2697 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2698 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2699 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2700 debug|(?:not|)forwarded|priority|
2701 (?:un|)block|limit|(?:un|)archive|
2702 reassign|retitle|affects|wrongpackage
2703 (?:un|force|)merge|user(?:category|tags?|)
2705 if (not length $paragraph) {
2706 print {$debug} "Found control/pseudo-headers and skiping them\n";
2707 $in_pseudoheaders = 1;
2711 next if $in_pseudoheaders;
2712 $paragraph .= $line ." \n";
2714 print {$debug} "Summary is going to be '$paragraph'\n";
2715 $summary = $paragraph;
2716 $summary =~ s/[\n\r]/ /g;
2717 if (not length $summary) {
2718 die "Unable to find summary message to use";
2720 # trim off a trailing spaces
2721 $summary =~ s/\ *$//;
2724 $summary = $param{summary};
2726 for my $data (@data) {
2727 print {$debug} "Going to change summary\n";
2728 if (((not defined $summary or not length $summary) and
2729 (not defined $data->{summary} or not length $data->{summary})) or
2730 $summary eq $data->{summary}) {
2731 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
2732 unless __internal_request();
2735 if (length $summary) {
2736 if (length $data->{summary}) {
2737 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2740 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2743 my $old_data = dclone($data);
2744 $data->{summary} = $summary;
2745 append_action_to_log(bug => $data->{bug_num},
2746 command => 'summary',
2747 old_data => $old_data,
2750 __return_append_to_log_options(
2755 if not exists $param{append_log} or $param{append_log};
2756 writebug($data->{bug_num},$data);
2757 print {$transcript} "$action\n";
2759 __end_control(%info);
2767 clone_bug(bug => $ref,
2768 transcript => $transcript,
2769 ($dl > 0 ? (debug => $transcript):()),
2770 requester => $header{from},
2771 request_addr => $controlrequestaddr,
2773 affected_packages => \%affected_packages,
2774 recipients => \%recipients,
2779 print {$transcript} "Failed to clone bug $ref bar: $@";
2782 Clones the given bug.
2784 We currently don't support cloning merged bugs, but this could be
2785 handled by internally unmerging, cloning, then remerging the bugs.
2790 my %param = validate_with(params => \@_,
2791 spec => {bug => {type => SCALAR,
2794 new_bugs => {type => ARRAYREF,
2796 new_clones => {type => HASHREF,
2800 %append_action_options,
2804 __begin_control(%param,
2807 my ($debug,$transcript) =
2808 @info{qw(debug transcript)};
2809 my @data = @{$info{data}};
2810 my @bugs = @{$info{bugs}};
2813 for my $data (@data) {
2814 if (length($data->{mergedwith})) {
2815 die "Bug is marked as being merged with others. Use an existing clone.\n";
2819 die "Not exactly one bug‽ This shouldn't happen.";
2821 my $data = $data[0];
2823 for my $newclone_id (@{$param{new_bugs}}) {
2824 my $new_bug_num = new_bug(copy => $data->{bug_num});
2825 $param{new_clones}{$newclone_id} = $new_bug_num;
2826 $clones{$newclone_id} = $new_bug_num;
2828 my @new_bugs = sort values %clones;
2830 for my $new_bug (@new_bugs) {
2831 # no collapsed ids or the higher collapsed id is not one less
2832 # than the next highest new bug
2833 if (not @collapsed_ids or
2834 $collapsed_ids[-1][1]+1 != $new_bug) {
2835 push @collapsed_ids,[$new_bug,$new_bug];
2838 $collapsed_ids[-1][1] = $new_bug;
2842 for my $ci (@collapsed_ids) {
2843 if ($ci->[0] == $ci->[1]) {
2844 push @collapsed,$ci->[0];
2847 push @collapsed,$ci->[0].'-'.$ci->[1]
2850 my $collapsed_str = english_join(\@collapsed);
2851 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2852 for my $new_bug (@new_bugs) {
2853 append_action_to_log(bug => $new_bug,
2855 __return_append_to_log_options(
2860 if not exists $param{append_log} or $param{append_log};
2862 append_action_to_log(bug => $data->{bug_num},
2864 __return_append_to_log_options(
2869 if not exists $param{append_log} or $param{append_log};
2870 writebug($data->{bug_num},$data);
2871 print {$transcript} "$action\n";
2872 __end_control(%info);
2873 # bugs that this bug is blocking are also blocked by the new clone(s)
2874 for my $bug (split ' ', $data->{blocks}) {
2875 for my $new_bug (@new_bugs) {
2876 set_blocks(bug => $new_bug,
2879 keys %common_options,
2880 keys %append_action_options),
2884 # bugs that this bug is blocked by are also blocking the new clone(s)
2885 for my $bug (split ' ', $data->{blockedby}) {
2886 for my $new_bug (@new_bugs) {
2887 set_blocks(bug => $bug,
2890 keys %common_options,
2891 keys %append_action_options),
2899 =head1 OWNER FUNCTIONS
2905 transcript => $transcript,
2906 ($dl > 0 ? (debug => $transcript):()),
2907 requester => $header{from},
2908 request_addr => $controlrequestaddr,
2910 recipients => \%recipients,
2916 print {$transcript} "Failed to mark $ref as having an owner: $@";
2919 Handles all setting of the owner field; given an owner of undef or of
2920 no length, indicates that a bug is not owned by anyone.
2925 my %param = validate_with(params => \@_,
2926 spec => {bug => {type => SCALAR,
2929 owner => {type => SCALAR|UNDEF,
2932 %append_action_options,
2936 __begin_control(%param,
2939 my ($debug,$transcript) =
2940 @info{qw(debug transcript)};
2941 my @data = @{$info{data}};
2942 my @bugs = @{$info{bugs}};
2944 for my $data (@data) {
2945 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2946 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2947 if (not defined $param{owner} or not length $param{owner}) {
2948 if (not defined $data->{owner} or not length $data->{owner}) {
2949 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2950 unless __internal_request();
2954 $action = "Removed annotation that $config{bug} was owned by " .
2958 if ($data->{owner} eq $param{owner}) {
2959 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2962 if (length $data->{owner}) {
2963 $action = "Owner changed from $data->{owner} to $param{owner}.";
2966 $action = "Owner recorded as $param{owner}."
2969 my $old_data = dclone($data);
2970 $data->{owner} = $param{owner};
2971 append_action_to_log(bug => $data->{bug_num},
2974 old_data => $old_data,
2976 __return_append_to_log_options(
2981 if not exists $param{append_log} or $param{append_log};
2982 writebug($data->{bug_num},$data);
2983 print {$transcript} "$action\n";
2985 __end_control(%info);
2989 =head1 ARCHIVE FUNCTIONS
2996 bug_archive(bug => $bug_num,
2998 transcript => \$transcript,
3003 transcript("Unable to archive $bug_num\n");
3006 transcript($transcript);
3009 This routine archives a bug
3013 =item bug -- bug number
3015 =item check_archiveable -- check wether a bug is archiveable before
3016 archiving; defaults to 1
3018 =item archive_unarchived -- whether to archive bugs which have not
3019 previously been archived; defaults to 1. [Set to 0 when used from
3022 =item ignore_time -- whether to ignore time constraints when archiving
3023 a bug; defaults to 0.
3030 my %param = validate_with(params => \@_,
3031 spec => {bug => {type => SCALAR,
3034 check_archiveable => {type => BOOLEAN,
3037 archive_unarchived => {type => BOOLEAN,
3040 ignore_time => {type => BOOLEAN,
3044 %append_action_options,
3047 my %info = __begin_control(%param,
3048 command => 'archive',
3050 my ($debug,$transcript) = @info{qw(debug transcript)};
3051 my @data = @{$info{data}};
3052 my @bugs = @{$info{bugs}};
3053 my $action = "$config{bug} archived.";
3054 if ($param{check_archiveable} and
3055 not bug_archiveable(bug=>$param{bug},
3056 ignore_time => $param{ignore_time},
3058 print {$transcript} "Bug $param{bug} cannot be archived\n";
3059 die "Bug $param{bug} cannot be archived";
3061 print {$debug} "$param{bug} considering\n";
3062 if (not $param{archive_unarchived} and
3063 not exists $data[0]{unarchived}
3065 print {$transcript} "$param{bug} has not been archived previously\n";
3066 die "$param{bug} has not been archived previously";
3068 add_recipients(recipients => $param{recipients},
3071 transcript => $transcript,
3073 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3074 for my $bug (@bugs) {
3075 if ($param{check_archiveable}) {
3076 die "Bug $bug cannot be archived (but $param{bug} can?)"
3077 unless bug_archiveable(bug=>$bug,
3078 ignore_time => $param{ignore_time},
3082 # If we get here, we can archive/remove this bug
3083 print {$debug} "$param{bug} removing\n";
3084 for my $bug (@bugs) {
3085 #print "$param{bug} removing $bug\n" if $debug;
3086 my $dir = get_hashname($bug);
3087 # First indicate that this bug is being archived
3088 append_action_to_log(bug => $bug,
3090 command => 'archive',
3091 # we didn't actually change the data
3092 # when we archived, so we don't pass
3093 # a real new_data or old_data
3096 __return_append_to_log_options(
3101 if not exists $param{append_log} or $param{append_log};
3102 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3103 if ($config{save_old_bugs}) {
3104 mkpath("$config{spool_dir}/archive/$dir");
3105 foreach my $file (@files_to_remove) {
3106 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3107 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3108 # we need to bail out here if things have
3109 # gone horribly wrong to avoid removing a
3111 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3114 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3116 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3117 print {$debug} "deleted $bug (from $param{bug})\n";
3119 bughook_archive(@bugs);
3120 __end_control(%info);
3123 =head2 bug_unarchive
3127 bug_unarchive(bug => $bug_num,
3129 transcript => \$transcript,
3134 transcript("Unable to archive bug: $bug_num");
3136 transcript($transcript);
3138 This routine unarchives a bug
3143 my %param = validate_with(params => \@_,
3144 spec => {bug => {type => SCALAR,
3148 %append_action_options,
3152 my %info = __begin_control(%param,
3154 command=>'unarchive');
3155 my ($debug,$transcript) =
3156 @info{qw(debug transcript)};
3157 my @data = @{$info{data}};
3158 my @bugs = @{$info{bugs}};
3159 my $action = "$config{bug} unarchived.";
3160 my @files_to_remove;
3161 for my $bug (@bugs) {
3162 print {$debug} "$param{bug} removing $bug\n";
3163 my $dir = get_hashname($bug);
3164 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3165 mkpath("archive/$dir");
3166 foreach my $file (@files_to_copy) {
3167 # die'ing here sucks
3168 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3169 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3170 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3172 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3173 print {$transcript} "Unarchived $config{bug} $bug\n";
3175 unlink(@files_to_remove) or die "Unable to unlink bugs";
3176 # Indicate that this bug has been archived previously
3177 for my $bug (@bugs) {
3178 my $newdata = readbug($bug);
3179 my $old_data = dclone($newdata);
3180 if (not defined $newdata) {
3181 print {$transcript} "$config{bug} $bug disappeared!\n";
3182 die "Bug $bug disappeared!";
3184 $newdata->{unarchived} = time;
3185 append_action_to_log(bug => $bug,
3187 command => 'unarchive',
3188 new_data => $newdata,
3189 old_data => $old_data,
3190 __return_append_to_log_options(
3195 if not exists $param{append_log} or $param{append_log};
3196 writebug($bug,$newdata);
3198 __end_control(%info);
3201 =head2 append_action_to_log
3203 append_action_to_log
3205 This should probably be moved to Debbugs::Log; have to think that out
3210 sub append_action_to_log{
3211 my %param = validate_with(params => \@_,
3212 spec => {bug => {type => SCALAR,
3215 new_data => {type => HASHREF,
3218 old_data => {type => HASHREF,
3221 command => {type => SCALAR,
3224 action => {type => SCALAR,
3226 requester => {type => SCALAR,
3229 request_addr => {type => SCALAR,
3232 location => {type => SCALAR,
3235 message => {type => SCALAR|ARRAYREF,
3238 recips => {type => SCALAR|ARRAYREF,
3241 desc => {type => SCALAR,
3244 get_lock => {type => BOOLEAN,
3247 locks => {type => HASHREF,
3251 # append_action_options here
3252 # because some of these
3253 # options aren't actually
3254 # optional, even though the
3255 # original function doesn't
3259 # Fix this to use $param{location}
3260 my $log_location = buglog($param{bug});
3261 die "Unable to find .log for $param{bug}"
3262 if not defined $log_location;
3263 if ($param{get_lock}) {
3264 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3268 my $logfh = IO::File->new(">>$log_location") or
3269 die "Unable to open $log_location for appending: $!";
3270 # determine difference between old and new
3272 if (exists $param{old_data} and exists $param{new_data}) {
3273 my $old_data = dclone($param{old_data});
3274 my $new_data = dclone($param{new_data});
3275 for my $key (keys %{$old_data}) {
3276 if (not exists $Debbugs::Status::fields{$key}) {
3277 delete $old_data->{$key};
3280 next unless exists $new_data->{$key};
3281 next unless defined $new_data->{$key};
3282 if (not defined $old_data->{$key}) {
3283 delete $old_data->{$key};
3286 if (ref($new_data->{$key}) and
3287 ref($old_data->{$key}) and
3288 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3289 local $Storable::canonical = 1;
3290 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3291 delete $new_data->{$key};
3292 delete $old_data->{$key};
3295 elsif ($new_data->{$key} eq $old_data->{$key}) {
3296 delete $new_data->{$key};
3297 delete $old_data->{$key};
3300 for my $key (keys %{$new_data}) {
3301 if (not exists $Debbugs::Status::fields{$key}) {
3302 delete $new_data->{$key};
3305 next unless exists $old_data->{$key};
3306 next unless defined $old_data->{$key};
3307 if (not defined $new_data->{$key} or
3308 not exists $Debbugs::Status::fields{$key}) {
3309 delete $new_data->{$key};
3312 if (ref($new_data->{$key}) and
3313 ref($old_data->{$key}) and
3314 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3315 local $Storable::canonical = 1;
3316 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3317 delete $new_data->{$key};
3318 delete $old_data->{$key};
3321 elsif ($new_data->{$key} eq $old_data->{$key}) {
3322 delete $new_data->{$key};
3323 delete $old_data->{$key};
3326 $data_diff .= "<!-- new_data:\n";
3328 for my $key (keys %{$new_data}) {
3329 if (not exists $Debbugs::Status::fields{$key}) {
3330 warn "No such field $key";
3333 $nd{$key} = $new_data->{$key};
3334 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3336 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3337 $data_diff .= "-->\n";
3338 $data_diff .= "<!-- old_data:\n";
3340 for my $key (keys %{$old_data}) {
3341 if (not exists $Debbugs::Status::fields{$key}) {
3342 warn "No such field $key";
3345 $od{$key} = $old_data->{$key};
3346 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3348 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3349 $data_diff .= "-->\n";
3352 (exists $param{command} ?
3353 "<!-- command:".html_escape($param{command})." -->\n":""
3355 (length $param{requester} ?
3356 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3358 (length $param{request_addr} ?
3359 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3361 "<!-- time:".time()." -->\n",
3363 "<strong>".html_escape($param{action})."</strong>\n");
3364 if (length $param{requester}) {
3365 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3367 if (length $param{request_addr}) {
3368 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3370 if (length $param{desc}) {
3371 $msg .= ":<br>\n$param{desc}\n";
3376 push @records, {type => 'html',
3380 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3381 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3382 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3383 text => join('',make_list($param{message})),
3386 write_log_records(logfh=>$logfh,
3387 records => \@records,
3389 close $logfh or die "Unable to close $log_location: $!";
3390 if ($param{get_lock}) {
3391 unfilelock(exists $param{locks}?$param{locks}:());
3399 =head1 PRIVATE FUNCTIONS
3401 =head2 __handle_affected_packages
3403 __handle_affected_packages(affected_packages => {},
3411 sub __handle_affected_packages{
3412 my %param = validate_with(params => \@_,
3413 spec => {%common_options,
3414 data => {type => ARRAYREF|HASHREF
3419 for my $data (make_list($param{data})) {
3420 next unless exists $data->{package} and defined $data->{package};
3421 my @packages = split /\s*,\s*/,$data->{package};
3422 @{$param{affected_packages}}{@packages} = (1) x @packages;
3426 =head2 __handle_debug_transcript
3428 my ($debug,$transcript) = __handle_debug_transcript(%param);
3430 Returns a debug and transcript filehandle
3435 sub __handle_debug_transcript{
3436 my %param = validate_with(params => \@_,
3437 spec => {%common_options},
3440 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3441 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3442 return ($debug,$transcript);
3449 Produces a small bit of bug information to kick out to the transcript
3456 next unless defined $data and exists $data->{bug_num};
3457 $return .= "Bug #".($data->{bug_num}||'').
3458 ((defined $data->{done} and length $data->{done})?
3459 " {Done: $data->{done}}":''
3461 " [".($data->{package}||'(no package)'). "] ".
3462 ($data->{subject}||'(no subject)')."\n";
3468 =head2 __internal_request
3470 __internal_request()
3471 __internal_request($level)
3473 Returns true if the caller of the function calling __internal_request
3474 belongs to __PACKAGE__
3476 This allows us to be magical, and don't bother to print bug info if
3477 the second caller is from this package, amongst other things.
3479 An optional level is allowed, which increments the number of levels to
3480 check by the given value. [This is basically for use by internal
3481 functions like __begin_control which are always called by
3486 sub __internal_request{
3488 $l = 0 if not defined $l;
3489 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3495 sub __return_append_to_log_options{
3497 my $action = $param{action} if exists $param{action};
3498 if (not exists $param{requester}) {
3499 $param{requester} = $config{control_internal_requester};
3501 if (not exists $param{request_addr}) {
3502 $param{request_addr} = $config{control_internal_request_addr};
3504 if (not exists $param{message}) {
3505 my $date = rfc822_date();
3506 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3507 variables => {request_addr => $param{request_addr},
3508 requester => $param{requester},
3514 if (not defined $action) {
3515 carp "Undefined action!";
3516 $action = "unknown action";
3518 return (action => $action,
3519 hash_slice(%param,keys %append_action_options),
3523 =head2 __begin_control
3525 my %info = __begin_control(%param,
3527 command=>'unarchive');
3528 my ($debug,$transcript) = @info{qw(debug transcript)};
3529 my @data = @{$info{data}};
3530 my @bugs = @{$info{bugs}};
3533 Starts the process of modifying a bug; handles all of the generic
3534 things that almost every control request needs
3536 Returns a hash containing
3540 =item new_locks -- number of new locks taken out by this call
3542 =item debug -- the debug file handle
3544 =item transcript -- the transcript file handle
3546 =item data -- an arrayref containing the data of the bugs
3547 corresponding to this request
3549 =item bugs -- an arrayref containing the bug numbers of the bugs
3550 corresponding to this request
3558 sub __begin_control {
3559 my %param = validate_with(params => \@_,
3560 spec => {bug => {type => SCALAR,
3563 archived => {type => BOOLEAN,
3566 command => {type => SCALAR,
3574 my ($debug,$transcript) = __handle_debug_transcript(@_);
3575 print {$debug} "$param{bug} considering\n";
3576 $lockhash = $param{locks} if exists $param{locks};
3578 my $old_die = $SIG{__DIE__};
3579 $SIG{__DIE__} = *sig_die{CODE};
3581 ($new_locks, @data) =
3582 lock_read_all_merged_bugs(bug => $param{bug},
3583 $param{archived}?(location => 'archive'):(),
3584 exists $param{locks} ? (locks => $param{locks}):(),
3586 $locks += $new_locks;
3588 die "Unable to read any bugs successfully.";
3590 if (not $param{archived}) {
3591 for my $data (@data) {
3592 if ($data->{archived}) {
3593 die "Not altering archived bugs; see unarchive.";
3597 if (not __check_limit(data => \@data,
3598 exists $param{limit}?(limit => $param{limit}):(),
3599 transcript => $transcript,
3601 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3604 __handle_affected_packages(%param,data => \@data);
3605 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3606 print {$debug} "$param{bug} read $locks locks\n";
3607 if (not @data or not defined $data[0]) {
3608 print {$transcript} "No bug found for $param{bug}\n";
3609 die "No bug found for $param{bug}";
3612 add_recipients(data => \@data,
3613 recipients => $param{recipients},
3614 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3616 (__internal_request()?(transcript => $transcript):()),
3619 print {$debug} "$param{bug} read done\n";
3620 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3621 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3622 return (data => \@data,
3624 old_die => $old_die,
3625 new_locks => $new_locks,
3627 transcript => $transcript,
3629 exists $param{locks}?(locks => $param{locks}):(),
3633 =head2 __end_control
3635 __end_control(%info);
3637 Handles tearing down from a control request
3643 if (exists $info{new_locks} and $info{new_locks} > 0) {
3644 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3645 for (1..$info{new_locks}) {
3646 unfilelock(exists $info{locks}?$info{locks}:());
3650 $SIG{__DIE__} = $info{old_die};
3651 if (exists $info{param}{affected_bugs}) {
3652 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3654 add_recipients(recipients => $info{param}{recipients},
3655 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3656 data => $info{data},
3657 debug => $info{debug},
3658 transcript => $info{transcript},
3660 __handle_affected_packages(%{$info{param}},data=>$info{data});
3664 =head2 __check_limit
3666 __check_limit(data => \@data, limit => $param{limit});
3669 Checks to make sure that bugs match any limits; each entry of @data
3670 much satisfy the limit.
3672 Returns true if there are no entries in data, or there are no keys in
3673 limit; returns false (0) if there are any entries which do not match.
3675 The limit hashref elements can contain an arrayref of scalars to
3676 match; regexes are also acccepted. At least one of the entries in each
3677 element needs to match the corresponding field in all data for the
3684 my %param = validate_with(params => \@_,
3685 spec => {data => {type => ARRAYREF|SCALAR,
3687 limit => {type => HASHREF|UNDEF,
3689 transcript => {type => SCALARREF|HANDLE,
3694 my @data = make_list($param{data});
3696 not defined $param{limit} or
3697 not keys %{$param{limit}}) {
3700 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3701 my $going_to_fail = 0;
3702 for my $data (@data) {
3703 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3704 status => dclone($data),
3706 for my $field (keys %{$param{limit}}) {
3707 next unless exists $param{limit}{$field};
3709 my @data_fields = make_list($data->{$field});
3710 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3711 if (not ref $limit) {
3712 for my $data_field (@data_fields) {
3713 if ($data_field eq $limit) {
3719 elsif (ref($limit) eq 'Regexp') {
3720 for my $data_field (@data_fields) {
3721 if ($data_field =~ $limit) {
3728 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3733 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3734 "' does not match at least one of ".
3735 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3739 return $going_to_fail?0:1;
3747 We override die to specially handle unlocking files in the cases where
3748 we are called via eval. [If we're not called via eval, it doesn't
3754 if ($^S) { # in eval
3756 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3763 # =head2 __message_body_template
3765 # message_body_template('mail/ack',{ref=>'foo'});
3767 # Creates a message body using a template
3771 sub __message_body_template{
3772 my ($template,$extra_var) = @_;
3774 my $hole_var = {'&bugurl' =>
3776 'http://'.$config{cgi_domain}.'/'.
3777 Debbugs::CGI::bug_url($_[0]);
3781 my $body = fill_in_template(template => $template,
3782 variables => {config => \%config,
3785 hole_var => $hole_var,
3787 return fill_in_template(template => 'mail/message_body',
3788 variables => {config => \%config,
3792 hole_var => $hole_var,
3796 sub __all_undef_or_equal {
3798 return 1 if @values == 1 or @values == 0;
3799 my $not_def = grep {not defined $_} @values;
3800 if ($not_def == @values) {
3803 if ($not_def > 0 and $not_def != @values) {
3806 my $first_val = shift @values;
3807 for my $val (@values) {
3808 if ($first_val ne $val) {