1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Control;
14 Debbugs::Control -- Routines for modifying the state of bugs
23 This module is an abstraction of a lot of functions which originally
24 were only present in service.in, but as time has gone on needed to be
25 called from elsewhere.
27 All of the public functions take the following options:
31 =item debug -- scalar reference to which debbuging information is
34 =item transcript -- scalar reference to which transcript information
37 =item affected_bugs -- hashref which is updated with bugs affected by
43 Functions which should (probably) append to the .log file take the
48 =item requester -- Email address of the individual who requested the change
50 =item request_addr -- Address to which the request was sent
52 =item request_nn -- Name of queue file which caused this request
54 =item request_msgid -- Message id of message which caused this request
56 =item location -- Optional location; currently ignored but may be
57 supported in the future for updating archived bugs upon archival
59 =item message -- The original message which caused the action to be taken
61 =item append_log -- Whether or not to append information to the log.
65 B<append_log> (for most functions) is a special option. When set to
66 false, no appending to the log is done at all. When it is not present,
67 the above information is faked, and appended to the log file. When it
68 is true, the above options must be present, and their values are used.
71 =head1 GENERAL FUNCTIONS
77 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
78 use base qw(Exporter);
82 $DEBUG = 0 unless defined $DEBUG;
85 %EXPORT_TAGS = (done => [qw(set_done)],
86 submitter => [qw(set_submitter)],
87 severity => [qw(set_severity)],
88 affects => [qw(affects)],
89 summary => [qw(summary)],
91 title => [qw(set_title)],
92 forward => [qw(set_forwarded)],
93 found => [qw(set_found set_fixed)],
94 fixed => [qw(set_found set_fixed)],
95 package => [qw(set_package)],
96 block => [qw(set_blocks)],
97 merge => [qw(set_merged)],
99 clone => [qw(clone_bug)],
100 archive => [qw(bug_archive bug_unarchive),
102 log => [qw(append_action_to_log),
106 Exporter::export_ok_tags(keys %EXPORT_TAGS);
107 $EXPORT_TAGS{all} = [@EXPORT_OK];
110 use Debbugs::Config qw(:config);
111 use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions);
112 use Debbugs::Status qw(bug_archiveable :read :hook writebug new_bug splitpackages split_status_fields get_bug_status);
113 use Debbugs::CGI qw(html_escape);
114 use Debbugs::Log qw(:misc :write);
115 use Debbugs::Recipients qw(:add);
116 use Debbugs::Packages qw(:versions :mapping);
118 use Data::Dumper qw();
119 use Params::Validate qw(validate_with :types);
120 use File::Path qw(mkpath);
121 use File::Copy qw(copy);
124 use Debbugs::Text qw(:templates);
126 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
127 use Debbugs::MIME qw(create_mime_message);
129 use Mail::RFC822::Address qw();
131 use POSIX qw(strftime);
133 use Storable qw(dclone nfreeze);
134 use List::Util qw(first max);
138 # These are a set of options which are common to all of these functions
140 my %common_options = (debug => {type => SCALARREF|HANDLE,
143 transcript => {type => SCALARREF|HANDLE,
146 affected_bugs => {type => HASHREF,
149 affected_packages => {type => HASHREF,
152 recipients => {type => HASHREF,
155 limit => {type => HASHREF,
158 show_bug_info => {type => BOOLEAN,
161 request_subject => {type => SCALAR,
162 default => 'Unknown Subject',
164 request_msgid => {type => SCALAR,
167 request_nn => {type => SCALAR,
170 request_replyto => {type => SCALAR,
173 locks => {type => HASHREF,
179 my %append_action_options =
180 (action => {type => SCALAR,
183 requester => {type => SCALAR,
186 request_addr => {type => SCALAR,
189 location => {type => SCALAR,
192 message => {type => SCALAR|ARRAYREF,
195 append_log => {type => BOOLEAN,
197 depends => [qw(requester request_addr),
201 # locks is both an append_action option, and a common option;
202 # it's ok for it to be in both places.
203 locks => {type => HASHREF,
211 # this is just a generic stub for Debbugs::Control functions.
216 # set_foo(bug => $ref,
217 # transcript => $transcript,
218 # ($dl > 0 ? (debug => $transcript):()),
219 # requester => $header{from},
220 # request_addr => $controlrequestaddr,
222 # affected_packages => \%affected_packages,
223 # recipients => \%recipients,
229 # print {$transcript} "Failed to set foo $ref bar: $@";
237 # my %param = validate_with(params => \@_,
238 # spec => {bug => {type => SCALAR,
239 # regex => qr/^\d+$/,
241 # # specific options here
243 # %append_action_options,
247 # __begin_control(%param,
250 # my ($debug,$transcript) =
251 # @info{qw(debug transcript)};
252 # my @data = @{$info{data}};
253 # my @bugs = @{$info{bugs}};
256 # for my $data (@data) {
257 # append_action_to_log(bug => $data->{bug_num},
259 # __return_append_to_log_options(
264 # if not exists $param{append_log} or $param{append_log};
265 # writebug($data->{bug_num},$data);
266 # print {$transcript} "$action\n";
268 # __end_control(%info);
275 set_block(bug => $ref,
276 transcript => $transcript,
277 ($dl > 0 ? (debug => $transcript):()),
278 requester => $header{from},
279 request_addr => $controlrequestaddr,
281 affected_packages => \%affected_packages,
282 recipients => \%recipients,
288 print {$transcript} "Failed to set blockers of $ref: $@";
291 Alters the set of bugs that block this bug from being fixed
293 This requires altering both this bug (and those it's merged with) as
294 well as the bugs that block this bug from being fixed (and those that
299 =item block -- scalar or arrayref of blocking bugs to set, add or remove
301 =item add -- if true, add blocking bugs
303 =item remove -- if true, remove blocking bugs
310 my %param = validate_with(params => \@_,
311 spec => {bug => {type => SCALAR,
314 # specific options here
315 block => {type => SCALAR|ARRAYREF,
318 add => {type => BOOLEAN,
321 remove => {type => BOOLEAN,
325 %append_action_options,
328 if ($param{add} and $param{remove}) {
329 croak "It's nonsensical to add and remove the same blocking bugs";
331 if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
332 croak "Invalid blocking bug(s):".
333 join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
339 elsif ($param{remove}) {
344 __begin_control(%param,
347 my ($debug,$transcript) =
348 @info{qw(debug transcript)};
349 my @data = @{$info{data}};
350 my @bugs = @{$info{bugs}};
353 # The first bit of this code is ugly, and should be cleaned up.
354 # Its purpose is to populate %removed_blockers and %add_blockers
355 # with all of the bugs that should be added or removed as blockers
356 # of all of the bugs which are merged with $param{bug}
359 for my $blocker (make_list($param{block})) {
360 next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
361 my $data = read_bug(bug=>$blocker,
363 if (defined $data and not $data->{archive}) {
364 $data = split_status_fields($data);
365 $ok_blockers{$blocker} = 1;
367 push @merged_bugs, make_list($data->{mergedwith});
368 @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
371 $bad_blockers{$blocker} = 1;
375 # throw an error if we are setting the blockers and there is a bad
377 if (keys %bad_blockers and $mode eq 'set') {
378 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
379 keys %ok_blockers?'':" and no known blocking bug(s)";
381 # if there are no ok blockers and we are not setting the blockers,
383 if (not keys %ok_blockers and $mode ne 'set') {
384 print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
385 if (keys %bad_blockers) {
386 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
388 __end_control(%info);
392 my @change_blockers = keys %ok_blockers;
394 my %removed_blockers;
397 my @blockers = map {split ' ', $_->{blockedby}} @data;
399 @blockers{@blockers} = (1) x @blockers;
401 # it is nonsensical for a bug to block itself (or a merged
402 # partner); We currently don't allow removal because we'd possibly
406 @bugs{@bugs} = (1) x @bugs;
407 for my $blocker (@change_blockers) {
408 if ($bugs{$blocker}) {
409 croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
412 @blockers = keys %blockers;
414 %removed_blockers = ();
415 for my $blocker (@change_blockers) {
416 next if exists $blockers{$blocker};
417 $blockers{$blocker} = 1;
418 $added_blockers{$blocker} = 1;
421 elsif ($param{remove}) {
422 %added_blockers = ();
423 for my $blocker (@change_blockers) {
424 next if exists $removed_blockers{$blocker};
425 delete $blockers{$blocker};
426 $removed_blockers{$blocker} = 1;
430 @removed_blockers{@blockers} = (1) x @blockers;
432 for my $blocker (@change_blockers) {
433 next if exists $blockers{$blocker};
434 $blockers{$blocker} = 1;
435 if (exists $removed_blockers{$blocker}) {
436 delete $removed_blockers{$blocker};
439 $added_blockers{$blocker} = 1;
443 my @new_blockers = keys %blockers;
444 for my $data (@data) {
445 my $old_data = dclone($data);
446 # remove blockers and/or add new ones as appropriate
447 if ($data->{blockedby} eq '') {
448 print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n";
450 print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n";
452 if ($data->{blocks} eq '') {
453 print {$transcript} "$data->{bug_num} was not blocking any bugs.\n";
455 print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n";
458 push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
459 push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers;
460 $action = ucfirst(join ('; ',@changed)) if @changed;
462 print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n"
463 unless __internal_request();
466 $data->{blockedby} = join(' ',keys %blockers);
467 append_action_to_log(bug => $data->{bug_num},
469 old_data => $old_data,
472 __return_append_to_log_options(
477 if not exists $param{append_log} or $param{append_log};
478 writebug($data->{bug_num},$data);
479 print {$transcript} "$action\n";
481 # we do this bit below to avoid code duplication
483 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
484 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
486 for my $add_remove (keys %mungable_blocks) {
490 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
491 next if $munge_blockers{$blocker};
492 my ($temp_locks, @blocking_data) =
493 lock_read_all_merged_bugs(bug => $blocker,
494 ($param{archived}?(location => 'archive'):()),
495 exists $param{locks}?(locks => $param{locks}):(),
497 $locks+= $temp_locks;
498 $new_locks+=$temp_locks;
499 if (not @blocking_data) {
500 for (1..$new_locks) {
501 unfilelock(exists $param{locks}?$param{locks}:());
504 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
506 for (map {$_->{bug_num}} @blocking_data) {
507 $munge_blockers{$_} = 1;
509 for my $data (@blocking_data) {
510 my $old_data = dclone($data);
512 my @blocks = split ' ', $data->{blocks};
513 @blocks{@blocks} = (1) x @blocks;
515 for my $bug (@bugs) {
516 if ($add_remove eq 'remove') {
517 next unless exists $blocks{$bug};
518 delete $blocks{$bug};
521 next if exists $blocks{$bug};
526 $data->{blocks} = join(' ',sort keys %blocks);
527 my $action = ($add_remove eq 'add'?'Added':'Removed').
528 " indication that bug $data->{bug_num} blocks ".
530 append_action_to_log(bug => $data->{bug_num},
532 old_data => $old_data,
535 __return_append_to_log_options(%param,
539 writebug($data->{bug_num},$data);
541 __handle_affected_packages(%param,data=>\@blocking_data);
542 add_recipients(recipients => $param{recipients},
543 actions_taken => {blocks => 1},
544 data => \@blocking_data,
546 transcript => $transcript,
549 for (1..$new_locks) {
550 unfilelock(exists $param{locks}?$param{locks}:());
555 __end_control(%info);
564 transcript => $transcript,
565 ($dl > 0 ? (debug => $transcript):()),
566 requester => $header{from},
567 request_addr => $controlrequestaddr,
569 affected_packages => \%affected_packages,
570 recipients => \%recipients,
577 print {$transcript} "Failed to set tag on $ref: $@";
581 Sets, adds, or removes the specified tags on a bug
585 =item tag -- scalar or arrayref of tags to set, add or remove
587 =item add -- if true, add tags
589 =item remove -- if true, remove tags
591 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
599 my %param = validate_with(params => \@_,
600 spec => {bug => {type => SCALAR,
603 # specific options here
604 tag => {type => SCALAR|ARRAYREF,
607 add => {type => BOOLEAN,
610 remove => {type => BOOLEAN,
613 warn_on_bad_tags => {type => BOOLEAN,
617 %append_action_options,
620 if ($param{add} and $param{remove}) {
621 croak "It's nonsensical to add and remove the same tags";
625 __begin_control(%param,
628 my ($debug,$transcript) =
629 @info{qw(debug transcript)};
630 my @data = @{$info{data}};
631 my @bugs = @{$info{bugs}};
632 my @tags = make_list($param{tag});
633 if (not @tags and ($param{remove} or $param{add})) {
634 if ($param{remove}) {
635 print {$transcript} "Requested to remove no tags; doing nothing.\n";
638 print {$transcript} "Requested to add no tags; doing nothing.\n";
640 __end_control(%info);
643 # first things first, make the versions fully qualified source
645 for my $data (@data) {
646 my $action = 'Did not alter tags';
648 my %tag_removed = ();
649 my %fixed_removed = ();
650 my @old_tags = split /\,?\s+/, $data->{keywords};
652 @tags{@old_tags} = (1) x @old_tags;
654 my $old_data = dclone($data);
655 if (not $param{add} and not $param{remove}) {
656 $tag_removed{$_} = 1 for @old_tags;
660 for my $tag (@tags) {
661 if (not $param{remove} and
662 not defined first {$_ eq $tag} @{$config{tags}}) {
663 push @bad_tags, $tag;
667 if (not exists $tags{$tag}) {
669 $tag_added{$tag} = 1;
672 elsif ($param{remove}) {
673 if (exists $tags{$tag}) {
675 $tag_removed{$tag} = 1;
679 if (exists $tag_removed{$tag}) {
680 delete $tag_removed{$tag};
683 $tag_added{$tag} = 1;
688 if (@bad_tags and $param{warn_on_bad_tags}) {
689 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
690 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
692 $data->{keywords} = join(' ',keys %tags);
695 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
696 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
697 $action = ucfirst(join ('; ',@changed)) if @changed;
699 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
700 unless __internal_request();
704 append_action_to_log(bug => $data->{bug_num},
707 old_data => $old_data,
709 __return_append_to_log_options(
714 if not exists $param{append_log} or $param{append_log};
715 writebug($data->{bug_num},$data);
716 print {$transcript} "$action\n";
718 __end_control(%info);
726 set_severity(bug => $ref,
727 transcript => $transcript,
728 ($dl > 0 ? (debug => $transcript):()),
729 requester => $header{from},
730 request_addr => $controlrequestaddr,
732 affected_packages => \%affected_packages,
733 recipients => \%recipients,
734 severity => 'normal',
739 print {$transcript} "Failed to set the severity of bug $ref: $@";
742 Sets the severity of a bug. If severity is not passed, is undefined,
743 or has zero length, sets the severity to the default severity.
748 my %param = validate_with(params => \@_,
749 spec => {bug => {type => SCALAR,
752 # specific options here
753 severity => {type => SCALAR|UNDEF,
754 default => $config{default_severity},
757 %append_action_options,
760 if (not defined $param{severity} or
761 not length $param{severity}
763 $param{severity} = $config{default_severity};
766 # check validity of new severity
767 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
768 die "Severity '$param{severity}' is not a valid severity level";
771 __begin_control(%param,
772 command => 'severity'
774 my ($debug,$transcript) =
775 @info{qw(debug transcript)};
776 my @data = @{$info{data}};
777 my @bugs = @{$info{bugs}};
780 for my $data (@data) {
781 if (not defined $data->{severity}) {
782 $data->{severity} = $param{severity};
783 $action = "Severity set to '$param{severity}'";
786 if ($data->{severity} eq '') {
787 $data->{severity} = $config{default_severity};
789 if ($data->{severity} eq $param{severity}) {
790 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
793 $action = "Severity set to '$param{severity}' from '$data->{severity}'";
794 $data->{severity} = $param{severity};
796 append_action_to_log(bug => $data->{bug_num},
798 __return_append_to_log_options(
803 if not exists $param{append_log} or $param{append_log};
804 writebug($data->{bug_num},$data);
805 print {$transcript} "$action\n";
807 __end_control(%info);
814 set_done(bug => $ref,
815 transcript => $transcript,
816 ($dl > 0 ? (debug => $transcript):()),
817 requester => $header{from},
818 request_addr => $controlrequestaddr,
820 affected_packages => \%affected_packages,
821 recipients => \%recipients,
826 print {$transcript} "Failed to set foo $ref bar: $@";
834 my %param = validate_with(params => \@_,
835 spec => {bug => {type => SCALAR,
838 reopen => {type => BOOLEAN,
841 submitter => {type => SCALAR,
844 clear_fixed => {type => BOOLEAN,
847 notify_submitter => {type => BOOLEAN,
850 original_report => {type => SCALARREF,
853 done => {type => SCALAR|UNDEF,
857 %append_action_options,
861 if (exists $param{submitter} and
862 not Mail::RFC822::Address::valid($param{submitter})) {
863 die "New submitter address '$param{submitter}' is not a valid e-mail address";
865 if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address
866 $param{done} = $param{requester};
868 if (exists $param{done} and
869 (not defined $param{done} or
870 not length $param{done})) {
876 __begin_control(%param,
877 command => $param{reopen}?'reopen':'done',
879 my ($debug,$transcript) =
880 @info{qw(debug transcript)};
881 my @data = @{$info{data}};
882 my @bugs = @{$info{bugs}};
885 if ($param{reopen}) {
886 # avoid warning multiple times if there are fixed versions
888 for my $data (@data) {
889 if (not exists $data->{done} or
890 not defined $data->{done} or
891 not length $data->{done}) {
892 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
893 __end_control(%info);
896 if (@{$data->{fixed_versions}} and $warn_fixed) {
897 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
898 print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n";
902 $action = "Bug reopened";
903 for my $data (@data) {
904 my $old_data = dclone($data);
906 append_action_to_log(bug => $data->{bug_num},
909 old_data => $old_data,
911 __return_append_to_log_options(
916 if not exists $param{append_log} or $param{append_log};
917 writebug($data->{bug_num},$data);
919 print {$transcript} "$action\n";
920 __end_control(%info);
921 if (exists $param{submitter}) {
922 set_submitter(bug => $param{bug},
923 submitter => $param{submitter},
925 keys %common_options,
926 keys %append_action_options)
929 # clear the fixed revisions
930 if ($param{clear_fixed}) {
931 set_fixed(fixed => [],
935 keys %common_options,
936 keys %append_action_options),
941 my %submitter_notified;
942 my $requester_notified = 0;
943 my $orig_report_set = 0;
944 for my $data (@data) {
945 if (exists $data->{done} and
946 defined $data->{done} and
947 length $data->{done}) {
948 print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
949 __end_control(%info);
953 for my $data (@data) {
954 my $old_data = dclone($data);
955 my $hash = get_hashname($data->{bug_num});
956 my $report_fh = IO::File->new("db-h/$hash/$data->{bug_num}.report",'r') or
957 die "Unable to open original report db-h/$hash/$data->{bug_num}.report for reading: $!";
961 $orig_report= <$report_fh>;
964 if (not $orig_report_set and defined $orig_report and
965 length $orig_report and
966 exists $param{original_report}){
967 ${$param{original_report}} = $orig_report;
968 $orig_report_set = 1;
971 $action = "Marked $config{bug} as done";
973 # set done to the requester
974 $data->{done} = exists $param{done}?$param{done}:$param{requester};
975 append_action_to_log(bug => $data->{bug_num},
978 old_data => $old_data,
980 __return_append_to_log_options(
985 if not exists $param{append_log} or $param{append_log};
986 writebug($data->{bug_num},$data);
987 print {$transcript} "$action\n";
988 # get the original report
989 if ($param{notify_submitter}) {
990 my $submitter_message;
991 if(not exists $submitter_notified{$data->{originator}}) {
993 create_mime_message([default_headers(queue_file => $param{request_nn},
995 msgid => $param{request_msgid},
996 msgtype => 'notifdone',
997 pr_msg => 'they-closed',
999 [To => $data->{submitter},
1000 Subject => "$config{ubug}#$data->{bug_num} ".
1001 "closed by $param{requester} ($param{request_subject})",
1005 __message_body_template('mail/process_your_bug_done',
1007 replyto => (exists $param{request_replyto} ?
1008 $param{request_replyto} :
1009 $param{requester} || 'Unknown'),
1010 markedby => $param{requester},
1011 subject => $param{request_subject},
1012 messageid => $param{request_msgid},
1015 [join('',make_list($param{message})),$orig_report]
1017 send_mail_message(message => $submitter_message,
1018 recipients => $old_data->{submitter},
1020 $submitter_notified{$data->{originator}} = $submitter_message;
1023 $submitter_message = $submitter_notified{$data->{originator}};
1025 append_action_to_log(bug => $data->{bug_num},
1026 action => "Notification sent",
1028 request_addr => $data->{originator},
1029 desc => "$config{bug} acknowledged by developer.",
1030 recips => [$data->{originator}],
1031 message => $submitter_message,
1036 __end_control(%info);
1037 if (exists $param{fixed}) {
1038 set_fixed(fixed => $param{fixed},
1042 keys %common_options,
1043 keys %append_action_options
1051 =head2 set_submitter
1054 set_submitter(bug => $ref,
1055 transcript => $transcript,
1056 ($dl > 0 ? (debug => $transcript):()),
1057 requester => $header{from},
1058 request_addr => $controlrequestaddr,
1060 affected_packages => \%affected_packages,
1061 recipients => \%recipients,
1062 submitter => $new_submitter,
1063 notify_submitter => 1,
1068 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1071 Sets the submitter of a bug. If notify_submitter is true (the
1072 default), notifies the old submitter of a bug on changes
1077 my %param = validate_with(params => \@_,
1078 spec => {bug => {type => SCALAR,
1081 # specific options here
1082 submitter => {type => SCALAR,
1084 notify_submitter => {type => BOOLEAN,
1088 %append_action_options,
1091 if (not Mail::RFC822::Address::valid($param{submitter})) {
1092 die "New submitter address $param{submitter} is not a valid e-mail address";
1095 __begin_control(%param,
1096 command => 'submitter'
1098 my ($debug,$transcript) =
1099 @info{qw(debug transcript)};
1100 my @data = @{$info{data}};
1101 my @bugs = @{$info{bugs}};
1103 # here we only concern ourselves with the first of the merged bugs
1104 for my $data ($data[0]) {
1105 my $notify_old_submitter = 0;
1106 my $old_data = dclone($data);
1107 print {$debug} "Going to change bug submitter\n";
1108 if (((not defined $param{submitter} or not length $param{submitter}) and
1109 (not defined $data->{originator} or not length $data->{originator})) or
1110 (defined $param{submitter} and defined $data->{originator} and
1111 $param{submitter} eq $data->{originator})) {
1112 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
1113 unless __internal_request();
1117 if (defined $data->{originator} and length($data->{originator})) {
1118 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
1119 $notify_old_submitter = 1;
1122 $action= "Set $config{bug} submitter to '$param{submitter}'.";
1124 $data->{originator} = $param{submitter};
1126 append_action_to_log(bug => $data->{bug_num},
1127 command => 'submitter',
1129 old_data => $old_data,
1131 __return_append_to_log_options(
1136 if not exists $param{append_log} or $param{append_log};
1137 writebug($data->{bug_num},$data);
1138 print {$transcript} "$action\n";
1139 # notify old submitter
1140 if ($notify_old_submitter and $param{notify_submitter}) {
1141 send_mail_message(message =>
1142 create_mime_message([default_headers(queue_file => $param{request_nn},
1144 msgid => $param{request_msgid},
1146 pr_msg => 'submitter-changed',
1148 [To => $old_data->{submitter},
1149 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
1153 __message_body_template('mail/submitter_changed',
1154 {old_data => $old_data,
1156 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
1160 recipients => $old_data->{submitter},
1164 __end_control(%info);
1169 =head2 set_forwarded
1172 set_forwarded(bug => $ref,
1173 transcript => $transcript,
1174 ($dl > 0 ? (debug => $transcript):()),
1175 requester => $header{from},
1176 request_addr => $controlrequestaddr,
1178 affected_packages => \%affected_packages,
1179 recipients => \%recipients,
1180 forwarded => $forward_to,
1185 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1188 Sets the location to which a bug is forwarded. Given an undef
1189 forwarded, unsets forwarded.
1195 my %param = validate_with(params => \@_,
1196 spec => {bug => {type => SCALAR,
1199 # specific options here
1200 forwarded => {type => SCALAR|UNDEF,
1203 %append_action_options,
1206 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1207 die "Non-printable characters are not allowed in the forwarded field";
1209 $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
1211 __begin_control(%param,
1212 command => 'forwarded'
1214 my ($debug,$transcript) =
1215 @info{qw(debug transcript)};
1216 my @data = @{$info{data}};
1217 my @bugs = @{$info{bugs}};
1219 for my $data (@data) {
1220 my $old_data = dclone($data);
1221 print {$debug} "Going to change bug forwarded\n";
1222 if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
1223 (not defined $param{forwarded} and
1224 defined $data->{forwarded} and not length $data->{forwarded})) {
1225 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1226 unless __internal_request();
1230 if (not defined $param{forwarded}) {
1231 $action= "Unset $config{bug} forwarded-to-address";
1233 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1234 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1237 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1239 $data->{forwarded} = $param{forwarded};
1241 append_action_to_log(bug => $data->{bug_num},
1242 command => 'forwarded',
1244 old_data => $old_data,
1246 __return_append_to_log_options(
1251 if not exists $param{append_log} or $param{append_log};
1252 writebug($data->{bug_num},$data);
1253 print {$transcript} "$action\n";
1255 __end_control(%info);
1264 set_title(bug => $ref,
1265 transcript => $transcript,
1266 ($dl > 0 ? (debug => $transcript):()),
1267 requester => $header{from},
1268 request_addr => $controlrequestaddr,
1270 affected_packages => \%affected_packages,
1271 recipients => \%recipients,
1272 title => $new_title,
1277 print {$transcript} "Failed to set the title of $ref: $@";
1280 Sets the title of a specific bug
1286 my %param = validate_with(params => \@_,
1287 spec => {bug => {type => SCALAR,
1290 # specific options here
1291 title => {type => SCALAR,
1294 %append_action_options,
1297 if ($param{title} =~ /[^[:print:]]/) {
1298 die "Non-printable characters are not allowed in bug titles";
1301 my %info = __begin_control(%param,
1304 my ($debug,$transcript) =
1305 @info{qw(debug transcript)};
1306 my @data = @{$info{data}};
1307 my @bugs = @{$info{bugs}};
1309 for my $data (@data) {
1310 my $old_data = dclone($data);
1311 print {$debug} "Going to change bug title\n";
1312 if (defined $data->{subject} and length($data->{subject}) and
1313 $data->{subject} eq $param{title}) {
1314 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1315 unless __internal_request();
1319 if (defined $data->{subject} and length($data->{subject})) {
1320 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1322 $action= "Set $config{bug} title to '$param{title}'.";
1324 $data->{subject} = $param{title};
1326 append_action_to_log(bug => $data->{bug_num},
1329 old_data => $old_data,
1331 __return_append_to_log_options(
1336 if not exists $param{append_log} or $param{append_log};
1337 writebug($data->{bug_num},$data);
1338 print {$transcript} "$action\n";
1340 __end_control(%info);
1347 set_package(bug => $ref,
1348 transcript => $transcript,
1349 ($dl > 0 ? (debug => $transcript):()),
1350 requester => $header{from},
1351 request_addr => $controlrequestaddr,
1353 affected_packages => \%affected_packages,
1354 recipients => \%recipients,
1355 package => $new_package,
1361 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1364 Indicates that a bug is in a particular package. If is_source is true,
1365 indicates that the package is a source package. [Internally, this
1366 causes src: to be prepended to the package name.]
1368 The default for is_source is 0. As a special case, if the package
1369 starts with 'src:', it is assumed to be a source package and is_source
1372 The package option must match the package_name_re regex.
1377 my %param = validate_with(params => \@_,
1378 spec => {bug => {type => SCALAR,
1381 # specific options here
1382 package => {type => SCALAR|ARRAYREF,
1384 is_source => {type => BOOLEAN,
1388 %append_action_options,
1391 my @new_packages = map {splitpackages($_)} make_list($param{package});
1392 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1393 croak "Invalid package name '".
1394 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1397 my %info = __begin_control(%param,
1398 command => 'package',
1400 my ($debug,$transcript) =
1401 @info{qw(debug transcript)};
1402 my @data = @{$info{data}};
1403 my @bugs = @{$info{bugs}};
1404 # clean up the new package
1408 ($temp =~ s/^src:// or
1409 $param{is_source}) ? 'src:'.$temp:$temp;
1413 my $package_reassigned = 0;
1414 for my $data (@data) {
1415 my $old_data = dclone($data);
1416 print {$debug} "Going to change assigned package\n";
1417 if (defined $data->{package} and length($data->{package}) and
1418 $data->{package} eq $new_package) {
1419 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1420 unless __internal_request();
1424 if (defined $data->{package} and length($data->{package})) {
1425 $package_reassigned = 1;
1426 $action= "$config{bug} reassigned from package '$data->{package}'".
1427 " to '$new_package'.";
1429 $action= "$config{bug} assigned to package '$new_package'.";
1431 $data->{package} = $new_package;
1433 append_action_to_log(bug => $data->{bug_num},
1434 command => 'package',
1436 old_data => $old_data,
1438 __return_append_to_log_options(
1443 if not exists $param{append_log} or $param{append_log};
1444 writebug($data->{bug_num},$data);
1445 print {$transcript} "$action\n";
1447 __end_control(%info);
1448 # Only clear the fixed/found versions if the package has been
1450 if ($package_reassigned) {
1451 my @params_for_found_fixed =
1452 map {exists $param{$_}?($_,$param{$_}):()}
1454 keys %common_options,
1455 keys %append_action_options,
1457 set_found(found => [],
1458 @params_for_found_fixed,
1460 set_fixed(fixed => [],
1461 @params_for_found_fixed,
1469 set_found(bug => $ref,
1470 transcript => $transcript,
1471 ($dl > 0 ? (debug => $transcript):()),
1472 requester => $header{from},
1473 request_addr => $controlrequestaddr,
1475 affected_packages => \%affected_packages,
1476 recipients => \%recipients,
1483 print {$transcript} "Failed to set found on $ref: $@";
1487 Sets, adds, or removes the specified found versions of a package
1489 If the version list is empty, and the bug is currently not "done",
1490 causes the done field to be cleared.
1492 If any of the versions added to found are greater than any version in
1493 which the bug is fixed (or when the bug is found and there are no
1494 fixed versions) the done field is cleared.
1499 my %param = validate_with(params => \@_,
1500 spec => {bug => {type => SCALAR,
1503 # specific options here
1504 found => {type => SCALAR|ARRAYREF,
1507 add => {type => BOOLEAN,
1510 remove => {type => BOOLEAN,
1514 %append_action_options,
1517 if ($param{add} and $param{remove}) {
1518 croak "It's nonsensical to add and remove the same versions";
1522 __begin_control(%param,
1525 my ($debug,$transcript) =
1526 @info{qw(debug transcript)};
1527 my @data = @{$info{data}};
1528 my @bugs = @{$info{bugs}};
1530 for my $version (make_list($param{found})) {
1531 next unless defined $version;
1532 $versions{$version} =
1533 [make_source_versions(package => [splitpackages($data[0]{package})],
1534 warnings => $transcript,
1537 versions => $version,
1540 # This is really ugly, but it's what we have to do
1541 if (not @{$versions{$version}}) {
1542 print {$transcript} "Unable to make a source version for version '$version'\n";
1545 if (not keys %versions and ($param{remove} or $param{add})) {
1546 if ($param{remove}) {
1547 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1550 print {$transcript} "Requested to add no versions; doing nothing.\n";
1552 __end_control(%info);
1555 # first things first, make the versions fully qualified source
1557 for my $data (@data) {
1558 # The 'done' field gets a bit weird with version tracking,
1559 # because a bug may be closed by multiple people in different
1560 # branches. Until we have something more flexible, we set it
1561 # every time a bug is fixed, and clear it when a bug is found
1562 # in a version greater than any version in which the bug is
1563 # fixed or when a bug is found and there is no fixed version
1564 my $action = 'Did not alter found versions';
1565 my %found_added = ();
1566 my %found_removed = ();
1567 my %fixed_removed = ();
1569 my $old_data = dclone($data);
1570 if (not $param{add} and not $param{remove}) {
1571 $found_removed{$_} = 1 for @{$data->{found_versions}};
1572 $data->{found_versions} = [];
1575 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1577 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1578 for my $version (keys %versions) {
1580 my @svers = @{$versions{$version}};
1584 for my $sver (@svers) {
1585 if (not exists $found_versions{$sver}) {
1586 $found_versions{$sver} = 1;
1587 $found_added{$sver} = 1;
1589 # if the found we are adding matches any fixed
1590 # versions, remove them
1591 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1592 delete $fixed_versions{$_} for @temp;
1593 $fixed_removed{$_} = 1 for @temp;
1596 # We only care about reopening the bug if the bug is
1598 if (defined $data->{done} and length $data->{done}) {
1599 my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
1601 # determine if we need to reopen
1602 my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
1603 keys %fixed_versions);
1604 if (not @fixed_order or
1605 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1611 elsif ($param{remove}) {
1612 # in the case of removal, we only concern ourself with
1613 # the version passed, not the source version it maps
1615 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1616 delete $found_versions{$_} for @temp;
1617 $found_removed{$_} = 1 for @temp;
1620 # set the keys to exactly these values
1621 my @svers = @{$versions{$version}};
1625 for my $sver (@svers) {
1626 if (not exists $found_versions{$sver}) {
1627 $found_versions{$sver} = 1;
1628 if (exists $found_removed{$sver}) {
1629 delete $found_removed{$sver};
1632 $found_added{$sver} = 1;
1639 $data->{found_versions} = [keys %found_versions];
1640 $data->{fixed_versions} = [keys %fixed_versions];
1643 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1644 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1645 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1646 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1647 $action = ucfirst(join ('; ',@changed)) if @changed;
1649 $action .= " and reopened"
1651 if (not $reopened and not @changed) {
1652 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1653 unless __internal_request();
1657 append_action_to_log(bug => $data->{bug_num},
1660 old_data => $old_data,
1662 __return_append_to_log_options(
1667 if not exists $param{append_log} or $param{append_log};
1668 writebug($data->{bug_num},$data);
1669 print {$transcript} "$action\n";
1671 __end_control(%info);
1677 set_fixed(bug => $ref,
1678 transcript => $transcript,
1679 ($dl > 0 ? (debug => $transcript):()),
1680 requester => $header{from},
1681 request_addr => $controlrequestaddr,
1683 affected_packages => \%affected_packages,
1684 recipients => \%recipients,
1692 print {$transcript} "Failed to set fixed on $ref: $@";
1696 Sets, adds, or removes the specified fixed versions of a package
1698 If the fixed versions are empty (or end up being empty after this
1699 call) or the greatest fixed version is less than the greatest found
1700 version and the reopen option is true, the bug is reopened.
1702 This function is also called by the reopen function, which causes all
1703 of the fixed versions to be cleared.
1708 my %param = validate_with(params => \@_,
1709 spec => {bug => {type => SCALAR,
1712 # specific options here
1713 fixed => {type => SCALAR|ARRAYREF,
1716 add => {type => BOOLEAN,
1719 remove => {type => BOOLEAN,
1722 reopen => {type => BOOLEAN,
1726 %append_action_options,
1729 if ($param{add} and $param{remove}) {
1730 croak "It's nonsensical to add and remove the same versions";
1733 __begin_control(%param,
1736 my ($debug,$transcript) =
1737 @info{qw(debug transcript)};
1738 my @data = @{$info{data}};
1739 my @bugs = @{$info{bugs}};
1741 for my $version (make_list($param{fixed})) {
1742 next unless defined $version;
1743 $versions{$version} =
1744 [make_source_versions(package => [splitpackages($data[0]{package})],
1745 warnings => $transcript,
1748 versions => $version,
1751 # This is really ugly, but it's what we have to do
1752 if (not @{$versions{$version}}) {
1753 print {$transcript} "Unable to make a source version for version '$version'\n";
1756 if (not keys %versions and ($param{remove} or $param{add})) {
1757 if ($param{remove}) {
1758 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1761 print {$transcript} "Requested to add no versions; doing nothing.\n";
1763 __end_control(%info);
1766 # first things first, make the versions fully qualified source
1768 for my $data (@data) {
1769 my $old_data = dclone($data);
1770 # The 'done' field gets a bit weird with version tracking,
1771 # because a bug may be closed by multiple people in different
1772 # branches. Until we have something more flexible, we set it
1773 # every time a bug is fixed, and clear it when a bug is found
1774 # in a version greater than any version in which the bug is
1775 # fixed or when a bug is found and there is no fixed version
1776 my $action = 'Did not alter fixed versions';
1777 my %found_added = ();
1778 my %found_removed = ();
1779 my %fixed_added = ();
1780 my %fixed_removed = ();
1782 if (not $param{add} and not $param{remove}) {
1783 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1784 $data->{fixed_versions} = [];
1787 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1789 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1790 for my $version (keys %versions) {
1792 my @svers = @{$versions{$version}};
1796 for my $sver (@svers) {
1797 if (not exists $fixed_versions{$sver}) {
1798 $fixed_versions{$sver} = 1;
1799 $fixed_added{$sver} = 1;
1803 elsif ($param{remove}) {
1804 # in the case of removal, we only concern ourself with
1805 # the version passed, not the source version it maps
1807 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1808 delete $fixed_versions{$_} for @temp;
1809 $fixed_removed{$_} = 1 for @temp;
1812 # set the keys to exactly these values
1813 my @svers = @{$versions{$version}};
1817 for my $sver (@svers) {
1818 if (not exists $fixed_versions{$sver}) {
1819 $fixed_versions{$sver} = 1;
1820 if (exists $fixed_removed{$sver}) {
1821 delete $fixed_removed{$sver};
1824 $fixed_added{$sver} = 1;
1831 $data->{found_versions} = [keys %found_versions];
1832 $data->{fixed_versions} = [keys %fixed_versions];
1834 # If we're supposed to consider reopening, reopen if the
1835 # fixed versions are empty or the greatest found version
1836 # is greater than the greatest fixed version
1837 if ($param{reopen} and defined $data->{done}
1838 and length $data->{done}) {
1839 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1840 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1841 # determine if we need to reopen
1842 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1843 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1844 if (not @fixed_order or
1845 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1852 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1853 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1854 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1855 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1856 $action = ucfirst(join ('; ',@changed)) if @changed;
1858 $action .= " and reopened"
1860 if (not $reopened and not @changed) {
1861 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1862 unless __internal_request();
1866 append_action_to_log(bug => $data->{bug_num},
1869 old_data => $old_data,
1871 __return_append_to_log_options(
1876 if not exists $param{append_log} or $param{append_log};
1877 writebug($data->{bug_num},$data);
1878 print {$transcript} "$action\n";
1880 __end_control(%info);
1887 set_merged(bug => $ref,
1888 transcript => $transcript,
1889 ($dl > 0 ? (debug => $transcript):()),
1890 requester => $header{from},
1891 request_addr => $controlrequestaddr,
1893 affected_packages => \%affected_packages,
1894 recipients => \%recipients,
1895 merge_with => 12345,
1898 allow_reassign => 1,
1899 reassign_same_source_only => 1,
1904 print {$transcript} "Failed to set merged on $ref: $@";
1908 Sets, adds, or removes the specified merged bugs of a bug
1910 By default, requires
1915 my %param = validate_with(params => \@_,
1916 spec => {bug => {type => SCALAR,
1919 # specific options here
1920 merge_with => {type => ARRAYREF|SCALAR,
1923 remove => {type => BOOLEAN,
1926 force => {type => BOOLEAN,
1929 masterbug => {type => BOOLEAN,
1932 allow_reassign => {type => BOOLEAN,
1935 reassign_different_sources => {type => BOOLEAN,
1939 %append_action_options,
1942 my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1944 @merging{@merging} = (1) x @merging;
1945 if (grep {$_ !~ /^\d+$/} @merging) {
1946 croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1948 $param{locks} = {} if not exists $param{locks};
1950 __begin_control(%param,
1953 my ($debug,$transcript) =
1954 @info{qw(debug transcript)};
1955 if (not @merging and exists $param{merge_with}) {
1956 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1957 __end_control(%info);
1960 my @data = @{$info{data}};
1961 my @bugs = @{$info{bugs}};
1964 for my $data (@data) {
1965 $data{$data->{bug_num}} = $data;
1966 my @merged_bugs = split / /, $data->{mergedwith};
1967 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1971 if (not exists $param{merge_with}) {
1972 my $ok_to_unmerge = 1;
1973 delete $merged_bugs{$param{bug}};
1974 if (not keys %merged_bugs) {
1975 print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1976 __end_control(%info);
1979 my $action = "Disconnected #$param{bug} from all other report(s).";
1980 for my $data (@data) {
1981 my $old_data = dclone($data);
1982 if ($data->{bug_num} == $param{bug}) {
1983 $data->{mergedwith} = '';
1986 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
1989 append_action_to_log(bug => $data->{bug_num},
1992 old_data => $old_data,
1994 __return_append_to_log_options(%param,
1998 if not exists $param{append_log} or $param{append_log};
1999 writebug($data->{bug_num},$data);
2001 print {$transcript} "$action\n";
2002 __end_control(%info);
2005 # lock and load all of the bugs we need
2006 my @bugs_to_load = keys %merging;
2009 my ($data,$n_locks) =
2010 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2012 locks => $param{locks},
2015 $new_locks += $n_locks;
2017 @data = values %data;
2018 if (not __check_limit(data => [@data],
2019 exists $param{limit}?(limit => $param{limit}):(),
2020 transcript => $transcript,
2022 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2024 for my $data (@data) {
2025 $data{$data->{bug_num}} = $data;
2026 $merged_bugs{$data->{bug_num}} = 1;
2027 my @merged_bugs = split / /, $data->{mergedwith};
2028 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2029 if (exists $param{affected_bugs}) {
2030 $param{affected_bugs}{$data->{bug_num}} = 1;
2033 __handle_affected_packages(%param,data => [@data]);
2034 my %bug_info_shown; # which bugs have had information shown
2035 $bug_info_shown{$param{bug}} = 1;
2036 add_recipients(data => [@data],
2037 recipients => $param{recipients},
2038 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2040 (__internal_request()?(transcript => $transcript):()),
2043 # Figure out what the ideal state is for the bug,
2044 my ($merge_status,$bugs_to_merge) =
2045 __calculate_merge_status(\@data,\%data,$param{bug});
2046 # find out if we actually have any bugs to merge
2047 if (not $bugs_to_merge) {
2048 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2049 for (1..$new_locks) {
2050 unfilelock($param{locks});
2053 __end_control(%info);
2056 # see what changes need to be made to merge the bugs
2057 # check to make sure that the set of changes we need to make is allowed
2058 my ($disallowed_changes,$changes) =
2059 __calculate_merge_changes(\@data,$merge_status,\%param);
2060 # at this point, stop if there are disallowed changes, otherwise
2061 # make the allowed changes, and then reread the bugs in question
2062 # to get the new data, then recaculate the merges; repeat
2063 # reloading and recalculating until we try too many times or there
2064 # are no changes to make.
2067 # we will allow at most 4 times through this; more than 1
2068 # shouldn't really happen.
2070 while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2071 if ($attempts > 1) {
2072 print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2074 if (@{$disallowed_changes}) {
2075 # figure out the problems
2076 print {$transcript} "Unable to merge bugs because:\n";
2077 for my $change (@{$disallowed_changes}) {
2078 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2080 if ($attempts > 0) {
2081 croak "Some bugs were altered while attempting to merge";
2084 croak "Did not alter merged bugs";
2087 my ($change_bug) = keys %{$changes};
2088 $bug_changed{$change_bug}++;
2089 print {$transcript} __bug_info($data{$change_bug}) if
2090 $param{show_bug_info} and not __internal_request(1);
2091 $bug_info_shown{$change_bug} = 1;
2092 __allow_relocking($param{locks},[keys %data]);
2093 for my $change (@{$changes->{$change_bug}}) {
2094 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2095 my %target_blockedby;
2096 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2097 my %unhandled_targets = %target_blockedby;
2098 my @blocks_to_remove;
2099 for my $key (split / /,$change->{orig_value}) {
2100 delete $unhandled_targets{$key};
2101 next if exists $target_blockedby{$key};
2102 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2103 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2106 keys %common_options,
2107 keys %append_action_options),
2110 for my $key (keys %unhandled_targets) {
2111 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2112 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2115 keys %common_options,
2116 keys %append_action_options),
2121 $change->{function}->(bug => $change->{bug},
2122 $change->{key}, $change->{func_value},
2123 exists $change->{options}?@{$change->{options}}:(),
2125 keys %common_options,
2126 keys %append_action_options),
2130 __disallow_relocking($param{locks});
2131 my ($data,$n_locks) =
2132 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2134 locks => $param{locks},
2138 $new_locks += $n_locks;
2141 @data = values %data;
2142 ($merge_status,$bugs_to_merge) =
2143 __calculate_merge_status(\@data,\%data,$param{bug});
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 $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
2415 if ($param->{force}) {
2416 if ($field ne 'package') {
2417 push @{$changes{$data->{bug_num}}},$change;
2420 if ($param->{allow_reassign}) {
2421 if ($param->{reassign_different_sources}) {
2422 push @{$changes{$data->{bug_num}}},$change;
2425 # allow reassigning if binary_to_source returns at
2426 # least one of the same source packages
2427 my @merge_status_source =
2428 binary_to_source(package => $merge_status->{package},
2431 my @other_bug_source =
2432 binary_to_source(package => $data->{package},
2435 my %merge_status_sources;
2436 @merge_status_sources{@merge_status_source} =
2437 (1) x @merge_status_source;
2438 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2439 push @{$changes{$data->{bug_num}}},$change;
2444 push @disallowed_changes,$change;
2446 # blocks and blocked by are weird; we have to go through and
2447 # set blocks to the other half of the merged bugs
2449 return (\@disallowed_changes,\%changes);
2455 affects(bug => $ref,
2456 transcript => $transcript,
2457 ($dl > 0 ? (debug => $transcript):()),
2458 requester => $header{from},
2459 request_addr => $controlrequestaddr,
2461 affected_packages => \%affected_packages,
2462 recipients => \%recipients,
2470 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2473 This marks a bug as affecting packages which the bug is not actually
2474 in. This should only be used in cases where fixing the bug instantly
2475 resolves the problem in the other packages.
2477 By default, the packages are set to the list of packages passed.
2478 However, if you pass add => 1 or remove => 1, the list of packages
2479 passed are added or removed from the affects list, respectively.
2484 my %param = validate_with(params => \@_,
2485 spec => {bug => {type => SCALAR,
2488 # specific options here
2489 package => {type => SCALAR|ARRAYREF|UNDEF,
2492 add => {type => BOOLEAN,
2495 remove => {type => BOOLEAN,
2499 %append_action_options,
2502 if ($param{add} and $param{remove}) {
2503 croak "Asking to both add and remove affects is nonsensical";
2505 if (not defined $param{package}) {
2506 $param{package} = [];
2509 __begin_control(%param,
2510 command => 'affects'
2512 my ($debug,$transcript) =
2513 @info{qw(debug transcript)};
2514 my @data = @{$info{data}};
2515 my @bugs = @{$info{bugs}};
2517 for my $data (@data) {
2519 print {$debug} "Going to change affects\n";
2520 my @packages = splitpackages($data->{affects});
2522 @packages{@packages} = (1) x @packages;
2525 for my $package (make_list($param{package})) {
2526 next unless defined $package and length $package;
2527 if (not $packages{$package}) {
2528 $packages{$package} = 1;
2529 push @added,$package;
2533 $action = "Added indication that $data->{bug_num} affects ".
2534 english_join(\@added);
2537 elsif ($param{remove}) {
2539 for my $package (make_list($param{package})) {
2540 if ($packages{$package}) {
2541 next unless defined $package and length $package;
2542 delete $packages{$package};
2543 push @removed,$package;
2546 $action = "Removed indication that $data->{bug_num} affects " .
2547 english_join(\@removed);
2550 my %added_packages = ();
2551 my %removed_packages = %packages;
2553 for my $package (make_list($param{package})) {
2554 next unless defined $package and length $package;
2555 $packages{$package} = 1;
2556 delete $removed_packages{$package};
2557 $added_packages{$package} = 1;
2559 if (keys %removed_packages) {
2560 $action = "Removed indication that $data->{bug_num} affects ".
2561 english_join([keys %removed_packages]);
2562 $action .= "\n" if keys %added_packages;
2564 if (keys %added_packages) {
2565 $action .= "Added indication that $data->{bug_num} affects " .
2566 english_join([keys %added_packages]);
2569 if (not length $action) {
2570 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
2571 unless __internal_request();
2574 my $old_data = dclone($data);
2575 $data->{affects} = join(',',keys %packages);
2576 append_action_to_log(bug => $data->{bug_num},
2578 command => 'affects',
2580 old_data => $old_data,
2581 __return_append_to_log_options(
2586 if not exists $param{append_log} or $param{append_log};
2587 writebug($data->{bug_num},$data);
2588 print {$transcript} "$action\n";
2590 __end_control(%info);
2594 =head1 SUMMARY FUNCTIONS
2599 summary(bug => $ref,
2600 transcript => $transcript,
2601 ($dl > 0 ? (debug => $transcript):()),
2602 requester => $header{from},
2603 request_addr => $controlrequestaddr,
2605 affected_packages => \%affected_packages,
2606 recipients => \%recipients,
2612 print {$transcript} "Failed to mark $ref with summary foo: $@";
2615 Handles all setting of summary fields
2617 If summary is undef, unsets the summary
2619 If summary is 0, sets the summary to the first paragraph contained in
2622 If summary is a positive integer, sets the summary to the message specified.
2624 Otherwise, sets summary to the value passed.
2630 my %param = validate_with(params => \@_,
2631 spec => {bug => {type => SCALAR,
2634 # specific options here
2635 summary => {type => SCALAR|UNDEF,
2639 %append_action_options,
2642 # croak "summary must be numeric or undef" if
2643 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2645 __begin_control(%param,
2646 command => 'summary'
2648 my ($debug,$transcript) =
2649 @info{qw(debug transcript)};
2650 my @data = @{$info{data}};
2651 my @bugs = @{$info{bugs}};
2652 # figure out the log that we're going to use
2654 my $summary_msg = '';
2656 if (not defined $param{summary}) {
2658 print {$debug} "Removing summary fields\n";
2659 $action = 'Removed summary';
2661 elsif ($param{summary} =~ /^\d+$/) {
2663 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2664 if ($param{summary} == 0) {
2665 $log = $param{message};
2666 $summary_msg = @records + 1;
2669 if (($param{summary} - 1 ) > $#records) {
2670 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2672 my $record = $records[($param{summary} - 1 )];
2673 if ($record->{type} !~ /incoming-recv|recips/) {
2674 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2676 $summary_msg = $param{summary};
2677 $log = [$record->{text}];
2679 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2680 my $body = $p_o->{body};
2681 my $in_pseudoheaders = 0;
2683 # walk through body until we get non-blank lines
2684 for my $line (@{$body}) {
2685 if ($line =~ /^\s*$/) {
2686 if (length $paragraph) {
2687 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2693 $in_pseudoheaders = 0;
2696 # skip a paragraph if it looks like it's control or
2698 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2699 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2700 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2701 debug|(?:not|)forwarded|priority|
2702 (?:un|)block|limit|(?:un|)archive|
2703 reassign|retitle|affects|wrongpackage
2704 (?:un|force|)merge|user(?:category|tags?|)
2706 if (not length $paragraph) {
2707 print {$debug} "Found control/pseudo-headers and skiping them\n";
2708 $in_pseudoheaders = 1;
2712 next if $in_pseudoheaders;
2713 $paragraph .= $line ." \n";
2715 print {$debug} "Summary is going to be '$paragraph'\n";
2716 $summary = $paragraph;
2717 $summary =~ s/[\n\r]/ /g;
2718 if (not length $summary) {
2719 die "Unable to find summary message to use";
2721 # trim off a trailing spaces
2722 $summary =~ s/\ *$//;
2725 $summary = $param{summary};
2727 for my $data (@data) {
2728 print {$debug} "Going to change summary\n";
2729 if (((not defined $summary or not length $summary) and
2730 (not defined $data->{summary} or not length $data->{summary})) or
2731 $summary eq $data->{summary}) {
2732 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
2733 unless __internal_request();
2736 if (length $summary) {
2737 if (length $data->{summary}) {
2738 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2741 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2744 my $old_data = dclone($data);
2745 $data->{summary} = $summary;
2746 append_action_to_log(bug => $data->{bug_num},
2747 command => 'summary',
2748 old_data => $old_data,
2751 __return_append_to_log_options(
2756 if not exists $param{append_log} or $param{append_log};
2757 writebug($data->{bug_num},$data);
2758 print {$transcript} "$action\n";
2760 __end_control(%info);
2768 clone_bug(bug => $ref,
2769 transcript => $transcript,
2770 ($dl > 0 ? (debug => $transcript):()),
2771 requester => $header{from},
2772 request_addr => $controlrequestaddr,
2774 affected_packages => \%affected_packages,
2775 recipients => \%recipients,
2780 print {$transcript} "Failed to clone bug $ref bar: $@";
2783 Clones the given bug.
2785 We currently don't support cloning merged bugs, but this could be
2786 handled by internally unmerging, cloning, then remerging the bugs.
2791 my %param = validate_with(params => \@_,
2792 spec => {bug => {type => SCALAR,
2795 new_bugs => {type => ARRAYREF,
2797 new_clones => {type => HASHREF,
2801 %append_action_options,
2805 __begin_control(%param,
2808 my ($debug,$transcript) =
2809 @info{qw(debug transcript)};
2810 my @data = @{$info{data}};
2811 my @bugs = @{$info{bugs}};
2814 for my $data (@data) {
2815 if (length($data->{mergedwith})) {
2816 die "Bug is marked as being merged with others. Use an existing clone.\n";
2820 die "Not exactly one bug‽ This shouldn't happen.";
2822 my $data = $data[0];
2824 for my $newclone_id (@{$param{new_bugs}}) {
2825 my $new_bug_num = new_bug(copy => $data->{bug_num});
2826 $param{new_clones}{$newclone_id} = $new_bug_num;
2827 $clones{$newclone_id} = $new_bug_num;
2829 my @new_bugs = sort values %clones;
2831 for my $new_bug (@new_bugs) {
2832 # no collapsed ids or the higher collapsed id is not one less
2833 # than the next highest new bug
2834 if (not @collapsed_ids or
2835 $collapsed_ids[-1][1]+1 != $new_bug) {
2836 push @collapsed_ids,[$new_bug,$new_bug];
2839 $collapsed_ids[-1][1] = $new_bug;
2843 for my $ci (@collapsed_ids) {
2844 if ($ci->[0] == $ci->[1]) {
2845 push @collapsed,$ci->[0];
2848 push @collapsed,$ci->[0].'-'.$ci->[1]
2851 my $collapsed_str = english_join(\@collapsed);
2852 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2853 for my $new_bug (@new_bugs) {
2854 append_action_to_log(bug => $new_bug,
2856 __return_append_to_log_options(
2861 if not exists $param{append_log} or $param{append_log};
2863 append_action_to_log(bug => $data->{bug_num},
2865 __return_append_to_log_options(
2870 if not exists $param{append_log} or $param{append_log};
2871 writebug($data->{bug_num},$data);
2872 print {$transcript} "$action\n";
2873 __end_control(%info);
2874 # bugs that this bug is blocking are also blocked by the new clone(s)
2875 for my $bug (split ' ', $data->{blocks}) {
2876 for my $new_bug (@new_bugs) {
2877 set_blocks(bug => $new_bug,
2880 keys %common_options,
2881 keys %append_action_options),
2885 # bugs that this bug is blocked by are also blocking the new clone(s)
2886 for my $bug (split ' ', $data->{blockedby}) {
2887 for my $new_bug (@new_bugs) {
2888 set_blocks(bug => $bug,
2891 keys %common_options,
2892 keys %append_action_options),
2900 =head1 OWNER FUNCTIONS
2906 transcript => $transcript,
2907 ($dl > 0 ? (debug => $transcript):()),
2908 requester => $header{from},
2909 request_addr => $controlrequestaddr,
2911 recipients => \%recipients,
2917 print {$transcript} "Failed to mark $ref as having an owner: $@";
2920 Handles all setting of the owner field; given an owner of undef or of
2921 no length, indicates that a bug is not owned by anyone.
2926 my %param = validate_with(params => \@_,
2927 spec => {bug => {type => SCALAR,
2930 owner => {type => SCALAR|UNDEF,
2933 %append_action_options,
2937 __begin_control(%param,
2940 my ($debug,$transcript) =
2941 @info{qw(debug transcript)};
2942 my @data = @{$info{data}};
2943 my @bugs = @{$info{bugs}};
2945 for my $data (@data) {
2946 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2947 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2948 if (not defined $param{owner} or not length $param{owner}) {
2949 if (not defined $data->{owner} or not length $data->{owner}) {
2950 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2951 unless __internal_request();
2955 $action = "Removed annotation that $config{bug} was owned by " .
2959 if ($data->{owner} eq $param{owner}) {
2960 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2963 if (length $data->{owner}) {
2964 $action = "Owner changed from $data->{owner} to $param{owner}.";
2967 $action = "Owner recorded as $param{owner}."
2970 my $old_data = dclone($data);
2971 $data->{owner} = $param{owner};
2972 append_action_to_log(bug => $data->{bug_num},
2975 old_data => $old_data,
2977 __return_append_to_log_options(
2982 if not exists $param{append_log} or $param{append_log};
2983 writebug($data->{bug_num},$data);
2984 print {$transcript} "$action\n";
2986 __end_control(%info);
2990 =head1 ARCHIVE FUNCTIONS
2997 bug_archive(bug => $bug_num,
2999 transcript => \$transcript,
3004 transcript("Unable to archive $bug_num\n");
3007 transcript($transcript);
3010 This routine archives a bug
3014 =item bug -- bug number
3016 =item check_archiveable -- check wether a bug is archiveable before
3017 archiving; defaults to 1
3019 =item archive_unarchived -- whether to archive bugs which have not
3020 previously been archived; defaults to 1. [Set to 0 when used from
3023 =item ignore_time -- whether to ignore time constraints when archiving
3024 a bug; defaults to 0.
3031 my %param = validate_with(params => \@_,
3032 spec => {bug => {type => SCALAR,
3035 check_archiveable => {type => BOOLEAN,
3038 archive_unarchived => {type => BOOLEAN,
3041 ignore_time => {type => BOOLEAN,
3045 %append_action_options,
3048 my %info = __begin_control(%param,
3049 command => 'archive',
3051 my ($debug,$transcript) = @info{qw(debug transcript)};
3052 my @data = @{$info{data}};
3053 my @bugs = @{$info{bugs}};
3054 my $action = "$config{bug} archived.";
3055 if ($param{check_archiveable} and
3056 not bug_archiveable(bug=>$param{bug},
3057 ignore_time => $param{ignore_time},
3059 print {$transcript} "Bug $param{bug} cannot be archived\n";
3060 die "Bug $param{bug} cannot be archived";
3062 print {$debug} "$param{bug} considering\n";
3063 if (not $param{archive_unarchived} and
3064 not exists $data[0]{unarchived}
3066 print {$transcript} "$param{bug} has not been archived previously\n";
3067 die "$param{bug} has not been archived previously";
3069 add_recipients(recipients => $param{recipients},
3072 transcript => $transcript,
3074 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3075 for my $bug (@bugs) {
3076 if ($param{check_archiveable}) {
3077 die "Bug $bug cannot be archived (but $param{bug} can?)"
3078 unless bug_archiveable(bug=>$bug,
3079 ignore_time => $param{ignore_time},
3083 # If we get here, we can archive/remove this bug
3084 print {$debug} "$param{bug} removing\n";
3085 for my $bug (@bugs) {
3086 #print "$param{bug} removing $bug\n" if $debug;
3087 my $dir = get_hashname($bug);
3088 # First indicate that this bug is being archived
3089 append_action_to_log(bug => $bug,
3091 command => 'archive',
3092 # we didn't actually change the data
3093 # when we archived, so we don't pass
3094 # a real new_data or old_data
3097 __return_append_to_log_options(
3102 if not exists $param{append_log} or $param{append_log};
3103 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3104 if ($config{save_old_bugs}) {
3105 mkpath("$config{spool_dir}/archive/$dir");
3106 foreach my $file (@files_to_remove) {
3107 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3108 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3109 # we need to bail out here if things have
3110 # gone horribly wrong to avoid removing a
3112 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3115 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3117 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3118 print {$debug} "deleted $bug (from $param{bug})\n";
3120 bughook_archive(@bugs);
3121 __end_control(%info);
3124 =head2 bug_unarchive
3128 bug_unarchive(bug => $bug_num,
3130 transcript => \$transcript,
3135 transcript("Unable to archive bug: $bug_num");
3137 transcript($transcript);
3139 This routine unarchives a bug
3144 my %param = validate_with(params => \@_,
3145 spec => {bug => {type => SCALAR,
3149 %append_action_options,
3153 my %info = __begin_control(%param,
3155 command=>'unarchive');
3156 my ($debug,$transcript) =
3157 @info{qw(debug transcript)};
3158 my @data = @{$info{data}};
3159 my @bugs = @{$info{bugs}};
3160 my $action = "$config{bug} unarchived.";
3161 my @files_to_remove;
3162 for my $bug (@bugs) {
3163 print {$debug} "$param{bug} removing $bug\n";
3164 my $dir = get_hashname($bug);
3165 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3166 mkpath("archive/$dir");
3167 foreach my $file (@files_to_copy) {
3168 # die'ing here sucks
3169 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3170 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3171 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3173 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3174 print {$transcript} "Unarchived $config{bug} $bug\n";
3176 unlink(@files_to_remove) or die "Unable to unlink bugs";
3177 # Indicate that this bug has been archived previously
3178 for my $bug (@bugs) {
3179 my $newdata = readbug($bug);
3180 my $old_data = dclone($newdata);
3181 if (not defined $newdata) {
3182 print {$transcript} "$config{bug} $bug disappeared!\n";
3183 die "Bug $bug disappeared!";
3185 $newdata->{unarchived} = time;
3186 append_action_to_log(bug => $bug,
3188 command => 'unarchive',
3189 new_data => $newdata,
3190 old_data => $old_data,
3191 __return_append_to_log_options(
3196 if not exists $param{append_log} or $param{append_log};
3197 writebug($bug,$newdata);
3199 __end_control(%info);
3202 =head2 append_action_to_log
3204 append_action_to_log
3206 This should probably be moved to Debbugs::Log; have to think that out
3211 sub append_action_to_log{
3212 my %param = validate_with(params => \@_,
3213 spec => {bug => {type => SCALAR,
3216 new_data => {type => HASHREF,
3219 old_data => {type => HASHREF,
3222 command => {type => SCALAR,
3225 action => {type => SCALAR,
3227 requester => {type => SCALAR,
3230 request_addr => {type => SCALAR,
3233 location => {type => SCALAR,
3236 message => {type => SCALAR|ARRAYREF,
3239 recips => {type => SCALAR|ARRAYREF,
3242 desc => {type => SCALAR,
3245 get_lock => {type => BOOLEAN,
3248 locks => {type => HASHREF,
3252 # append_action_options here
3253 # because some of these
3254 # options aren't actually
3255 # optional, even though the
3256 # original function doesn't
3260 # Fix this to use $param{location}
3261 my $log_location = buglog($param{bug});
3262 die "Unable to find .log for $param{bug}"
3263 if not defined $log_location;
3264 if ($param{get_lock}) {
3265 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3269 my $logfh = IO::File->new(">>$log_location") or
3270 die "Unable to open $log_location for appending: $!";
3271 # determine difference between old and new
3273 if (exists $param{old_data} and exists $param{new_data}) {
3274 my $old_data = dclone($param{old_data});
3275 my $new_data = dclone($param{new_data});
3276 for my $key (keys %{$old_data}) {
3277 if (not exists $Debbugs::Status::fields{$key}) {
3278 delete $old_data->{$key};
3281 next unless exists $new_data->{$key};
3282 next unless defined $new_data->{$key};
3283 if (not defined $old_data->{$key}) {
3284 delete $old_data->{$key};
3287 if (ref($new_data->{$key}) and
3288 ref($old_data->{$key}) and
3289 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3290 local $Storable::canonical = 1;
3291 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3292 delete $new_data->{$key};
3293 delete $old_data->{$key};
3296 elsif ($new_data->{$key} eq $old_data->{$key}) {
3297 delete $new_data->{$key};
3298 delete $old_data->{$key};
3301 for my $key (keys %{$new_data}) {
3302 if (not exists $Debbugs::Status::fields{$key}) {
3303 delete $new_data->{$key};
3306 next unless exists $old_data->{$key};
3307 next unless defined $old_data->{$key};
3308 if (not defined $new_data->{$key} or
3309 not exists $Debbugs::Status::fields{$key}) {
3310 delete $new_data->{$key};
3313 if (ref($new_data->{$key}) and
3314 ref($old_data->{$key}) and
3315 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3316 local $Storable::canonical = 1;
3317 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3318 delete $new_data->{$key};
3319 delete $old_data->{$key};
3322 elsif ($new_data->{$key} eq $old_data->{$key}) {
3323 delete $new_data->{$key};
3324 delete $old_data->{$key};
3327 $data_diff .= "<!-- new_data:\n";
3329 for my $key (keys %{$new_data}) {
3330 if (not exists $Debbugs::Status::fields{$key}) {
3331 warn "No such field $key";
3334 $nd{$key} = $new_data->{$key};
3335 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3337 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3338 $data_diff .= "-->\n";
3339 $data_diff .= "<!-- old_data:\n";
3341 for my $key (keys %{$old_data}) {
3342 if (not exists $Debbugs::Status::fields{$key}) {
3343 warn "No such field $key";
3346 $od{$key} = $old_data->{$key};
3347 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3349 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3350 $data_diff .= "-->\n";
3353 (exists $param{command} ?
3354 "<!-- command:".html_escape($param{command})." -->\n":""
3356 (length $param{requester} ?
3357 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3359 (length $param{request_addr} ?
3360 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3362 "<!-- time:".time()." -->\n",
3364 "<strong>".html_escape($param{action})."</strong>\n");
3365 if (length $param{requester}) {
3366 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3368 if (length $param{request_addr}) {
3369 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3371 if (length $param{desc}) {
3372 $msg .= ":<br>\n$param{desc}\n";
3377 push @records, {type => 'html',
3381 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3382 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3383 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3384 text => join('',make_list($param{message})),
3387 write_log_records(logfh=>$logfh,
3388 records => \@records,
3390 close $logfh or die "Unable to close $log_location: $!";
3391 if ($param{get_lock}) {
3392 unfilelock(exists $param{locks}?$param{locks}:());
3400 =head1 PRIVATE FUNCTIONS
3402 =head2 __handle_affected_packages
3404 __handle_affected_packages(affected_packages => {},
3412 sub __handle_affected_packages{
3413 my %param = validate_with(params => \@_,
3414 spec => {%common_options,
3415 data => {type => ARRAYREF|HASHREF
3420 for my $data (make_list($param{data})) {
3421 next unless exists $data->{package} and defined $data->{package};
3422 my @packages = split /\s*,\s*/,$data->{package};
3423 @{$param{affected_packages}}{@packages} = (1) x @packages;
3427 =head2 __handle_debug_transcript
3429 my ($debug,$transcript) = __handle_debug_transcript(%param);
3431 Returns a debug and transcript filehandle
3436 sub __handle_debug_transcript{
3437 my %param = validate_with(params => \@_,
3438 spec => {%common_options},
3441 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3442 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3443 return ($debug,$transcript);
3450 Produces a small bit of bug information to kick out to the transcript
3457 next unless defined $data and exists $data->{bug_num};
3458 $return .= "Bug #".($data->{bug_num}||'').
3459 ((defined $data->{done} and length $data->{done})?
3460 " {Done: $data->{done}}":''
3462 " [".($data->{package}||'(no package)'). "] ".
3463 ($data->{subject}||'(no subject)')."\n";
3469 =head2 __internal_request
3471 __internal_request()
3472 __internal_request($level)
3474 Returns true if the caller of the function calling __internal_request
3475 belongs to __PACKAGE__
3477 This allows us to be magical, and don't bother to print bug info if
3478 the second caller is from this package, amongst other things.
3480 An optional level is allowed, which increments the number of levels to
3481 check by the given value. [This is basically for use by internal
3482 functions like __begin_control which are always called by
3487 sub __internal_request{
3489 $l = 0 if not defined $l;
3490 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3496 sub __return_append_to_log_options{
3498 my $action = $param{action} if exists $param{action};
3499 if (not exists $param{requester}) {
3500 $param{requester} = $config{control_internal_requester};
3502 if (not exists $param{request_addr}) {
3503 $param{request_addr} = $config{control_internal_request_addr};
3505 if (not exists $param{message}) {
3506 my $date = rfc822_date();
3507 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3508 variables => {request_addr => $param{request_addr},
3509 requester => $param{requester},
3515 if (not defined $action) {
3516 carp "Undefined action!";
3517 $action = "unknown action";
3519 return (action => $action,
3520 hash_slice(%param,keys %append_action_options),
3524 =head2 __begin_control
3526 my %info = __begin_control(%param,
3528 command=>'unarchive');
3529 my ($debug,$transcript) = @info{qw(debug transcript)};
3530 my @data = @{$info{data}};
3531 my @bugs = @{$info{bugs}};
3534 Starts the process of modifying a bug; handles all of the generic
3535 things that almost every control request needs
3537 Returns a hash containing
3541 =item new_locks -- number of new locks taken out by this call
3543 =item debug -- the debug file handle
3545 =item transcript -- the transcript file handle
3547 =item data -- an arrayref containing the data of the bugs
3548 corresponding to this request
3550 =item bugs -- an arrayref containing the bug numbers of the bugs
3551 corresponding to this request
3559 sub __begin_control {
3560 my %param = validate_with(params => \@_,
3561 spec => {bug => {type => SCALAR,
3564 archived => {type => BOOLEAN,
3567 command => {type => SCALAR,
3575 my ($debug,$transcript) = __handle_debug_transcript(@_);
3576 print {$debug} "$param{bug} considering\n";
3577 $lockhash = $param{locks} if exists $param{locks};
3579 my $old_die = $SIG{__DIE__};
3580 $SIG{__DIE__} = *sig_die{CODE};
3582 ($new_locks, @data) =
3583 lock_read_all_merged_bugs(bug => $param{bug},
3584 $param{archived}?(location => 'archive'):(),
3585 exists $param{locks} ? (locks => $param{locks}):(),
3587 $locks += $new_locks;
3589 die "Unable to read any bugs successfully.";
3591 if (not $param{archived}) {
3592 for my $data (@data) {
3593 if ($data->{archived}) {
3594 die "Not altering archived bugs; see unarchive.";
3598 if (not __check_limit(data => \@data,
3599 exists $param{limit}?(limit => $param{limit}):(),
3600 transcript => $transcript,
3602 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3605 __handle_affected_packages(%param,data => \@data);
3606 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3607 print {$debug} "$param{bug} read $locks locks\n";
3608 if (not @data or not defined $data[0]) {
3609 print {$transcript} "No bug found for $param{bug}\n";
3610 die "No bug found for $param{bug}";
3613 add_recipients(data => \@data,
3614 recipients => $param{recipients},
3615 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3617 (__internal_request()?(transcript => $transcript):()),
3620 print {$debug} "$param{bug} read done\n";
3621 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3622 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3623 return (data => \@data,
3625 old_die => $old_die,
3626 new_locks => $new_locks,
3628 transcript => $transcript,
3630 exists $param{locks}?(locks => $param{locks}):(),
3634 =head2 __end_control
3636 __end_control(%info);
3638 Handles tearing down from a control request
3644 if (exists $info{new_locks} and $info{new_locks} > 0) {
3645 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3646 for (1..$info{new_locks}) {
3647 unfilelock(exists $info{locks}?$info{locks}:());
3651 $SIG{__DIE__} = $info{old_die};
3652 if (exists $info{param}{affected_bugs}) {
3653 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3655 add_recipients(recipients => $info{param}{recipients},
3656 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3657 data => $info{data},
3658 debug => $info{debug},
3659 transcript => $info{transcript},
3661 __handle_affected_packages(%{$info{param}},data=>$info{data});
3665 =head2 __check_limit
3667 __check_limit(data => \@data, limit => $param{limit});
3670 Checks to make sure that bugs match any limits; each entry of @data
3671 much satisfy the limit.
3673 Returns true if there are no entries in data, or there are no keys in
3674 limit; returns false (0) if there are any entries which do not match.
3676 The limit hashref elements can contain an arrayref of scalars to
3677 match; regexes are also acccepted. At least one of the entries in each
3678 element needs to match the corresponding field in all data for the
3685 my %param = validate_with(params => \@_,
3686 spec => {data => {type => ARRAYREF|SCALAR,
3688 limit => {type => HASHREF|UNDEF,
3690 transcript => {type => SCALARREF|HANDLE,
3695 my @data = make_list($param{data});
3697 not defined $param{limit} or
3698 not keys %{$param{limit}}) {
3701 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3702 my $going_to_fail = 0;
3703 for my $data (@data) {
3704 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3705 status => dclone($data),
3707 for my $field (keys %{$param{limit}}) {
3708 next unless exists $param{limit}{$field};
3710 my @data_fields = make_list($data->{$field});
3711 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3712 if (not ref $limit) {
3713 for my $data_field (@data_fields) {
3714 if ($data_field eq $limit) {
3720 elsif (ref($limit) eq 'Regexp') {
3721 for my $data_field (@data_fields) {
3722 if ($data_field =~ $limit) {
3729 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3734 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3735 "' does not match at least one of ".
3736 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3740 return $going_to_fail?0:1;
3748 We override die to specially handle unlocking files in the cases where
3749 we are called via eval. [If we're not called via eval, it doesn't
3755 if ($^S) { # in eval
3757 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3764 # =head2 __message_body_template
3766 # message_body_template('mail/ack',{ref=>'foo'});
3768 # Creates a message body using a template
3772 sub __message_body_template{
3773 my ($template,$extra_var) = @_;
3775 my $hole_var = {'&bugurl' =>
3777 'http://'.$config{cgi_domain}.'/'.
3778 Debbugs::CGI::bug_url($_[0]);
3782 my $body = fill_in_template(template => $template,
3783 variables => {config => \%config,
3786 hole_var => $hole_var,
3788 return fill_in_template(template => 'mail/message_body',
3789 variables => {config => \%config,
3793 hole_var => $hole_var,
3797 sub __all_undef_or_equal {
3799 return 1 if @values == 1 or @values == 0;
3800 my $not_def = grep {not defined $_} @values;
3801 if ($not_def == @values) {
3804 if ($not_def > 0 and $not_def != @values) {
3807 my $first_val = shift @values;
3808 for my $val (@values) {
3809 if ($first_val ne $val) {