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->{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 if ($param->{force}) {
2414 if ($field ne 'package') {
2415 push @{$changes{$data->{bug_num}}},$change;
2418 if ($param->{allow_reassign}) {
2419 if ($param->{reassign_different_sources}) {
2420 push @{$changes{$data->{bug_num}}},$change;
2423 # allow reassigning if binary_to_source returns at
2424 # least one of the same source packages
2425 my @merge_status_source =
2426 binary_to_source(package => $merge_status->{package},
2429 my @other_bug_source =
2430 binary_to_source(package => $data->{package},
2433 my %merge_status_sources;
2434 @merge_status_sources{@merge_status_source} =
2435 (1) x @merge_status_source;
2436 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2437 push @{$changes{$data->{bug_num}}},$change;
2442 push @disallowed_changes,$change;
2444 # blocks and blocked by are weird; we have to go through and
2445 # set blocks to the other half of the merged bugs
2447 return (\@disallowed_changes,\%changes);
2453 affects(bug => $ref,
2454 transcript => $transcript,
2455 ($dl > 0 ? (debug => $transcript):()),
2456 requester => $header{from},
2457 request_addr => $controlrequestaddr,
2459 affected_packages => \%affected_packages,
2460 recipients => \%recipients,
2468 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2471 This marks a bug as affecting packages which the bug is not actually
2472 in. This should only be used in cases where fixing the bug instantly
2473 resolves the problem in the other packages.
2475 By default, the packages are set to the list of packages passed.
2476 However, if you pass add => 1 or remove => 1, the list of packages
2477 passed are added or removed from the affects list, respectively.
2482 my %param = validate_with(params => \@_,
2483 spec => {bug => {type => SCALAR,
2486 # specific options here
2487 package => {type => SCALAR|ARRAYREF|UNDEF,
2490 add => {type => BOOLEAN,
2493 remove => {type => BOOLEAN,
2497 %append_action_options,
2500 if ($param{add} and $param{remove}) {
2501 croak "Asking to both add and remove affects is nonsensical";
2503 if (not defined $param{package}) {
2504 $param{package} = [];
2507 __begin_control(%param,
2508 command => 'affects'
2510 my ($debug,$transcript) =
2511 @info{qw(debug transcript)};
2512 my @data = @{$info{data}};
2513 my @bugs = @{$info{bugs}};
2515 for my $data (@data) {
2517 print {$debug} "Going to change affects\n";
2518 my @packages = splitpackages($data->{affects});
2520 @packages{@packages} = (1) x @packages;
2523 for my $package (make_list($param{package})) {
2524 next unless defined $package and length $package;
2525 if (not $packages{$package}) {
2526 $packages{$package} = 1;
2527 push @added,$package;
2531 $action = "Added indication that $data->{bug_num} affects ".
2532 english_join(\@added);
2535 elsif ($param{remove}) {
2537 for my $package (make_list($param{package})) {
2538 if ($packages{$package}) {
2539 next unless defined $package and length $package;
2540 delete $packages{$package};
2541 push @removed,$package;
2544 $action = "Removed indication that $data->{bug_num} affects " .
2545 english_join(\@removed);
2548 my %added_packages = ();
2549 my %removed_packages = %packages;
2551 for my $package (make_list($param{package})) {
2552 next unless defined $package and length $package;
2553 $packages{$package} = 1;
2554 delete $removed_packages{$package};
2555 $added_packages{$package} = 1;
2557 if (keys %removed_packages) {
2558 $action = "Removed indication that $data->{bug_num} affects ".
2559 english_join([keys %removed_packages]);
2560 $action .= "\n" if keys %added_packages;
2562 if (keys %added_packages) {
2563 $action .= "Added indication that $data->{bug_num} affects " .
2564 english_join([keys %added_packages]);
2567 if (not length $action) {
2568 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
2569 unless __internal_request();
2572 my $old_data = dclone($data);
2573 $data->{affects} = join(',',keys %packages);
2574 append_action_to_log(bug => $data->{bug_num},
2576 command => 'affects',
2578 old_data => $old_data,
2579 __return_append_to_log_options(
2584 if not exists $param{append_log} or $param{append_log};
2585 writebug($data->{bug_num},$data);
2586 print {$transcript} "$action\n";
2588 __end_control(%info);
2592 =head1 SUMMARY FUNCTIONS
2597 summary(bug => $ref,
2598 transcript => $transcript,
2599 ($dl > 0 ? (debug => $transcript):()),
2600 requester => $header{from},
2601 request_addr => $controlrequestaddr,
2603 affected_packages => \%affected_packages,
2604 recipients => \%recipients,
2610 print {$transcript} "Failed to mark $ref with summary foo: $@";
2613 Handles all setting of summary fields
2615 If summary is undef, unsets the summary
2617 If summary is 0, sets the summary to the first paragraph contained in
2620 If summary is a positive integer, sets the summary to the message specified.
2622 Otherwise, sets summary to the value passed.
2628 my %param = validate_with(params => \@_,
2629 spec => {bug => {type => SCALAR,
2632 # specific options here
2633 summary => {type => SCALAR|UNDEF,
2637 %append_action_options,
2640 # croak "summary must be numeric or undef" if
2641 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2643 __begin_control(%param,
2644 command => 'summary'
2646 my ($debug,$transcript) =
2647 @info{qw(debug transcript)};
2648 my @data = @{$info{data}};
2649 my @bugs = @{$info{bugs}};
2650 # figure out the log that we're going to use
2652 my $summary_msg = '';
2654 if (not defined $param{summary}) {
2656 print {$debug} "Removing summary fields\n";
2657 $action = 'Removed summary';
2659 elsif ($param{summary} =~ /^\d+$/) {
2661 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2662 if ($param{summary} == 0) {
2663 $log = $param{message};
2664 $summary_msg = @records + 1;
2667 if (($param{summary} - 1 ) > $#records) {
2668 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2670 my $record = $records[($param{summary} - 1 )];
2671 if ($record->{type} !~ /incoming-recv|recips/) {
2672 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2674 $summary_msg = $param{summary};
2675 $log = [$record->{text}];
2677 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2678 my $body = $p_o->{body};
2679 my $in_pseudoheaders = 0;
2681 # walk through body until we get non-blank lines
2682 for my $line (@{$body}) {
2683 if ($line =~ /^\s*$/) {
2684 if (length $paragraph) {
2685 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2691 $in_pseudoheaders = 0;
2694 # skip a paragraph if it looks like it's control or
2696 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2697 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2698 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2699 debug|(?:not|)forwarded|priority|
2700 (?:un|)block|limit|(?:un|)archive|
2701 reassign|retitle|affects|wrongpackage
2702 (?:un|force|)merge|user(?:category|tags?|)
2704 if (not length $paragraph) {
2705 print {$debug} "Found control/pseudo-headers and skiping them\n";
2706 $in_pseudoheaders = 1;
2710 next if $in_pseudoheaders;
2711 $paragraph .= $line ." \n";
2713 print {$debug} "Summary is going to be '$paragraph'\n";
2714 $summary = $paragraph;
2715 $summary =~ s/[\n\r]/ /g;
2716 if (not length $summary) {
2717 die "Unable to find summary message to use";
2719 # trim off a trailing spaces
2720 $summary =~ s/\ *$//;
2723 $summary = $param{summary};
2725 for my $data (@data) {
2726 print {$debug} "Going to change summary\n";
2727 if (((not defined $summary or not length $summary) and
2728 (not defined $data->{summary} or not length $data->{summary})) or
2729 $summary eq $data->{summary}) {
2730 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
2731 unless __internal_request();
2734 if (length $summary) {
2735 if (length $data->{summary}) {
2736 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2739 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2742 my $old_data = dclone($data);
2743 $data->{summary} = $summary;
2744 append_action_to_log(bug => $data->{bug_num},
2745 command => 'summary',
2746 old_data => $old_data,
2749 __return_append_to_log_options(
2754 if not exists $param{append_log} or $param{append_log};
2755 writebug($data->{bug_num},$data);
2756 print {$transcript} "$action\n";
2758 __end_control(%info);
2766 clone_bug(bug => $ref,
2767 transcript => $transcript,
2768 ($dl > 0 ? (debug => $transcript):()),
2769 requester => $header{from},
2770 request_addr => $controlrequestaddr,
2772 affected_packages => \%affected_packages,
2773 recipients => \%recipients,
2778 print {$transcript} "Failed to clone bug $ref bar: $@";
2781 Clones the given bug.
2783 We currently don't support cloning merged bugs, but this could be
2784 handled by internally unmerging, cloning, then remerging the bugs.
2789 my %param = validate_with(params => \@_,
2790 spec => {bug => {type => SCALAR,
2793 new_bugs => {type => ARRAYREF,
2795 new_clones => {type => HASHREF,
2799 %append_action_options,
2803 __begin_control(%param,
2806 my ($debug,$transcript) =
2807 @info{qw(debug transcript)};
2808 my @data = @{$info{data}};
2809 my @bugs = @{$info{bugs}};
2812 for my $data (@data) {
2813 if (length($data->{mergedwith})) {
2814 die "Bug is marked as being merged with others. Use an existing clone.\n";
2818 die "Not exactly one bug‽ This shouldn't happen.";
2820 my $data = $data[0];
2822 for my $newclone_id (@{$param{new_bugs}}) {
2823 my $new_bug_num = new_bug(copy => $data->{bug_num});
2824 $param{new_clones}{$newclone_id} = $new_bug_num;
2825 $clones{$newclone_id} = $new_bug_num;
2827 my @new_bugs = sort values %clones;
2829 for my $new_bug (@new_bugs) {
2830 # no collapsed ids or the higher collapsed id is not one less
2831 # than the next highest new bug
2832 if (not @collapsed_ids or
2833 $collapsed_ids[-1][1]+1 != $new_bug) {
2834 push @collapsed_ids,[$new_bug,$new_bug];
2837 $collapsed_ids[-1][1] = $new_bug;
2841 for my $ci (@collapsed_ids) {
2842 if ($ci->[0] == $ci->[1]) {
2843 push @collapsed,$ci->[0];
2846 push @collapsed,$ci->[0].'-'.$ci->[1]
2849 my $collapsed_str = english_join(\@collapsed);
2850 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2851 for my $new_bug (@new_bugs) {
2852 append_action_to_log(bug => $new_bug,
2854 __return_append_to_log_options(
2859 if not exists $param{append_log} or $param{append_log};
2861 append_action_to_log(bug => $data->{bug_num},
2863 __return_append_to_log_options(
2868 if not exists $param{append_log} or $param{append_log};
2869 writebug($data->{bug_num},$data);
2870 print {$transcript} "$action\n";
2871 __end_control(%info);
2872 # bugs that this bug is blocking are also blocked by the new clone(s)
2873 for my $bug (split ' ', $data->{blocks}) {
2874 for my $new_bug (@new_bugs) {
2875 set_blocks(bug => $new_bug,
2878 keys %common_options,
2879 keys %append_action_options),
2883 # bugs that this bug is blocked by are also blocking the new clone(s)
2884 for my $bug (split ' ', $data->{blockedby}) {
2885 for my $new_bug (@new_bugs) {
2886 set_blocks(bug => $bug,
2889 keys %common_options,
2890 keys %append_action_options),
2898 =head1 OWNER FUNCTIONS
2904 transcript => $transcript,
2905 ($dl > 0 ? (debug => $transcript):()),
2906 requester => $header{from},
2907 request_addr => $controlrequestaddr,
2909 recipients => \%recipients,
2915 print {$transcript} "Failed to mark $ref as having an owner: $@";
2918 Handles all setting of the owner field; given an owner of undef or of
2919 no length, indicates that a bug is not owned by anyone.
2924 my %param = validate_with(params => \@_,
2925 spec => {bug => {type => SCALAR,
2928 owner => {type => SCALAR|UNDEF,
2931 %append_action_options,
2935 __begin_control(%param,
2938 my ($debug,$transcript) =
2939 @info{qw(debug transcript)};
2940 my @data = @{$info{data}};
2941 my @bugs = @{$info{bugs}};
2943 for my $data (@data) {
2944 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2945 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2946 if (not defined $param{owner} or not length $param{owner}) {
2947 if (not defined $data->{owner} or not length $data->{owner}) {
2948 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2949 unless __internal_request();
2953 $action = "Removed annotation that $config{bug} was owned by " .
2957 if ($data->{owner} eq $param{owner}) {
2958 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2961 if (length $data->{owner}) {
2962 $action = "Owner changed from $data->{owner} to $param{owner}.";
2965 $action = "Owner recorded as $param{owner}."
2968 my $old_data = dclone($data);
2969 $data->{owner} = $param{owner};
2970 append_action_to_log(bug => $data->{bug_num},
2973 old_data => $old_data,
2975 __return_append_to_log_options(
2980 if not exists $param{append_log} or $param{append_log};
2981 writebug($data->{bug_num},$data);
2982 print {$transcript} "$action\n";
2984 __end_control(%info);
2988 =head1 ARCHIVE FUNCTIONS
2995 bug_archive(bug => $bug_num,
2997 transcript => \$transcript,
3002 transcript("Unable to archive $bug_num\n");
3005 transcript($transcript);
3008 This routine archives a bug
3012 =item bug -- bug number
3014 =item check_archiveable -- check wether a bug is archiveable before
3015 archiving; defaults to 1
3017 =item archive_unarchived -- whether to archive bugs which have not
3018 previously been archived; defaults to 1. [Set to 0 when used from
3021 =item ignore_time -- whether to ignore time constraints when archiving
3022 a bug; defaults to 0.
3029 my %param = validate_with(params => \@_,
3030 spec => {bug => {type => SCALAR,
3033 check_archiveable => {type => BOOLEAN,
3036 archive_unarchived => {type => BOOLEAN,
3039 ignore_time => {type => BOOLEAN,
3043 %append_action_options,
3046 my %info = __begin_control(%param,
3047 command => 'archive',
3049 my ($debug,$transcript) = @info{qw(debug transcript)};
3050 my @data = @{$info{data}};
3051 my @bugs = @{$info{bugs}};
3052 my $action = "$config{bug} archived.";
3053 if ($param{check_archiveable} and
3054 not bug_archiveable(bug=>$param{bug},
3055 ignore_time => $param{ignore_time},
3057 print {$transcript} "Bug $param{bug} cannot be archived\n";
3058 die "Bug $param{bug} cannot be archived";
3060 print {$debug} "$param{bug} considering\n";
3061 if (not $param{archive_unarchived} and
3062 not exists $data[0]{unarchived}
3064 print {$transcript} "$param{bug} has not been archived previously\n";
3065 die "$param{bug} has not been archived previously";
3067 add_recipients(recipients => $param{recipients},
3070 transcript => $transcript,
3072 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3073 for my $bug (@bugs) {
3074 if ($param{check_archiveable}) {
3075 die "Bug $bug cannot be archived (but $param{bug} can?)"
3076 unless bug_archiveable(bug=>$bug,
3077 ignore_time => $param{ignore_time},
3081 # If we get here, we can archive/remove this bug
3082 print {$debug} "$param{bug} removing\n";
3083 for my $bug (@bugs) {
3084 #print "$param{bug} removing $bug\n" if $debug;
3085 my $dir = get_hashname($bug);
3086 # First indicate that this bug is being archived
3087 append_action_to_log(bug => $bug,
3089 command => 'archive',
3090 # we didn't actually change the data
3091 # when we archived, so we don't pass
3092 # a real new_data or old_data
3095 __return_append_to_log_options(
3100 if not exists $param{append_log} or $param{append_log};
3101 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3102 if ($config{save_old_bugs}) {
3103 mkpath("$config{spool_dir}/archive/$dir");
3104 foreach my $file (@files_to_remove) {
3105 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3106 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3107 # we need to bail out here if things have
3108 # gone horribly wrong to avoid removing a
3110 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3113 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3115 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3116 print {$debug} "deleted $bug (from $param{bug})\n";
3118 bughook_archive(@bugs);
3119 __end_control(%info);
3122 =head2 bug_unarchive
3126 bug_unarchive(bug => $bug_num,
3128 transcript => \$transcript,
3133 transcript("Unable to archive bug: $bug_num");
3135 transcript($transcript);
3137 This routine unarchives a bug
3142 my %param = validate_with(params => \@_,
3143 spec => {bug => {type => SCALAR,
3147 %append_action_options,
3151 my %info = __begin_control(%param,
3153 command=>'unarchive');
3154 my ($debug,$transcript) =
3155 @info{qw(debug transcript)};
3156 my @data = @{$info{data}};
3157 my @bugs = @{$info{bugs}};
3158 my $action = "$config{bug} unarchived.";
3159 my @files_to_remove;
3160 for my $bug (@bugs) {
3161 print {$debug} "$param{bug} removing $bug\n";
3162 my $dir = get_hashname($bug);
3163 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3164 mkpath("archive/$dir");
3165 foreach my $file (@files_to_copy) {
3166 # die'ing here sucks
3167 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3168 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3169 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3171 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3172 print {$transcript} "Unarchived $config{bug} $bug\n";
3174 unlink(@files_to_remove) or die "Unable to unlink bugs";
3175 # Indicate that this bug has been archived previously
3176 for my $bug (@bugs) {
3177 my $newdata = readbug($bug);
3178 my $old_data = dclone($newdata);
3179 if (not defined $newdata) {
3180 print {$transcript} "$config{bug} $bug disappeared!\n";
3181 die "Bug $bug disappeared!";
3183 $newdata->{unarchived} = time;
3184 append_action_to_log(bug => $bug,
3186 command => 'unarchive',
3187 new_data => $newdata,
3188 old_data => $old_data,
3189 __return_append_to_log_options(
3194 if not exists $param{append_log} or $param{append_log};
3195 writebug($bug,$newdata);
3197 __end_control(%info);
3200 =head2 append_action_to_log
3202 append_action_to_log
3204 This should probably be moved to Debbugs::Log; have to think that out
3209 sub append_action_to_log{
3210 my %param = validate_with(params => \@_,
3211 spec => {bug => {type => SCALAR,
3214 new_data => {type => HASHREF,
3217 old_data => {type => HASHREF,
3220 command => {type => SCALAR,
3223 action => {type => SCALAR,
3225 requester => {type => SCALAR,
3228 request_addr => {type => SCALAR,
3231 location => {type => SCALAR,
3234 message => {type => SCALAR|ARRAYREF,
3237 recips => {type => SCALAR|ARRAYREF,
3240 desc => {type => SCALAR,
3243 get_lock => {type => BOOLEAN,
3246 locks => {type => HASHREF,
3250 # append_action_options here
3251 # because some of these
3252 # options aren't actually
3253 # optional, even though the
3254 # original function doesn't
3258 # Fix this to use $param{location}
3259 my $log_location = buglog($param{bug});
3260 die "Unable to find .log for $param{bug}"
3261 if not defined $log_location;
3262 if ($param{get_lock}) {
3263 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3267 my $logfh = IO::File->new(">>$log_location") or
3268 die "Unable to open $log_location for appending: $!";
3269 # determine difference between old and new
3271 if (exists $param{old_data} and exists $param{new_data}) {
3272 my $old_data = dclone($param{old_data});
3273 my $new_data = dclone($param{new_data});
3274 for my $key (keys %{$old_data}) {
3275 if (not exists $Debbugs::Status::fields{$key}) {
3276 delete $old_data->{$key};
3279 next unless exists $new_data->{$key};
3280 next unless defined $new_data->{$key};
3281 if (not defined $old_data->{$key}) {
3282 delete $old_data->{$key};
3285 if (ref($new_data->{$key}) and
3286 ref($old_data->{$key}) and
3287 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3288 local $Storable::canonical = 1;
3289 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3290 delete $new_data->{$key};
3291 delete $old_data->{$key};
3294 elsif ($new_data->{$key} eq $old_data->{$key}) {
3295 delete $new_data->{$key};
3296 delete $old_data->{$key};
3299 for my $key (keys %{$new_data}) {
3300 if (not exists $Debbugs::Status::fields{$key}) {
3301 delete $new_data->{$key};
3304 next unless exists $old_data->{$key};
3305 next unless defined $old_data->{$key};
3306 if (not defined $new_data->{$key} or
3307 not exists $Debbugs::Status::fields{$key}) {
3308 delete $new_data->{$key};
3311 if (ref($new_data->{$key}) and
3312 ref($old_data->{$key}) and
3313 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3314 local $Storable::canonical = 1;
3315 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3316 delete $new_data->{$key};
3317 delete $old_data->{$key};
3320 elsif ($new_data->{$key} eq $old_data->{$key}) {
3321 delete $new_data->{$key};
3322 delete $old_data->{$key};
3325 $data_diff .= "<!-- new_data:\n";
3327 for my $key (keys %{$new_data}) {
3328 if (not exists $Debbugs::Status::fields{$key}) {
3329 warn "No such field $key";
3332 $nd{$key} = $new_data->{$key};
3333 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3335 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3336 $data_diff .= "-->\n";
3337 $data_diff .= "<!-- old_data:\n";
3339 for my $key (keys %{$old_data}) {
3340 if (not exists $Debbugs::Status::fields{$key}) {
3341 warn "No such field $key";
3344 $od{$key} = $old_data->{$key};
3345 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3347 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3348 $data_diff .= "-->\n";
3351 (exists $param{command} ?
3352 "<!-- command:".html_escape($param{command})." -->\n":""
3354 (length $param{requester} ?
3355 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3357 (length $param{request_addr} ?
3358 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3360 "<!-- time:".time()." -->\n",
3362 "<strong>".html_escape($param{action})."</strong>\n");
3363 if (length $param{requester}) {
3364 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3366 if (length $param{request_addr}) {
3367 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3369 if (length $param{desc}) {
3370 $msg .= ":<br>\n$param{desc}\n";
3375 push @records, {type => 'html',
3379 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3380 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3381 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3382 text => join('',make_list($param{message})),
3385 write_log_records(logfh=>$logfh,
3386 records => \@records,
3388 close $logfh or die "Unable to close $log_location: $!";
3389 if ($param{get_lock}) {
3390 unfilelock(exists $param{locks}?$param{locks}:());
3398 =head1 PRIVATE FUNCTIONS
3400 =head2 __handle_affected_packages
3402 __handle_affected_packages(affected_packages => {},
3410 sub __handle_affected_packages{
3411 my %param = validate_with(params => \@_,
3412 spec => {%common_options,
3413 data => {type => ARRAYREF|HASHREF
3418 for my $data (make_list($param{data})) {
3419 next unless exists $data->{package} and defined $data->{package};
3420 my @packages = split /\s*,\s*/,$data->{package};
3421 @{$param{affected_packages}}{@packages} = (1) x @packages;
3425 =head2 __handle_debug_transcript
3427 my ($debug,$transcript) = __handle_debug_transcript(%param);
3429 Returns a debug and transcript filehandle
3434 sub __handle_debug_transcript{
3435 my %param = validate_with(params => \@_,
3436 spec => {%common_options},
3439 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3440 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3441 return ($debug,$transcript);
3448 Produces a small bit of bug information to kick out to the transcript
3455 next unless defined $data and exists $data->{bug_num};
3456 $return .= "Bug #".($data->{bug_num}||'').
3457 ((defined $data->{done} and length $data->{done})?
3458 " {Done: $data->{done}}":''
3460 " [".($data->{package}||'(no package)'). "] ".
3461 ($data->{subject}||'(no subject)')."\n";
3467 =head2 __internal_request
3469 __internal_request()
3470 __internal_request($level)
3472 Returns true if the caller of the function calling __internal_request
3473 belongs to __PACKAGE__
3475 This allows us to be magical, and don't bother to print bug info if
3476 the second caller is from this package, amongst other things.
3478 An optional level is allowed, which increments the number of levels to
3479 check by the given value. [This is basically for use by internal
3480 functions like __begin_control which are always called by
3485 sub __internal_request{
3487 $l = 0 if not defined $l;
3488 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3494 sub __return_append_to_log_options{
3496 my $action = $param{action} if exists $param{action};
3497 if (not exists $param{requester}) {
3498 $param{requester} = $config{control_internal_requester};
3500 if (not exists $param{request_addr}) {
3501 $param{request_addr} = $config{control_internal_request_addr};
3503 if (not exists $param{message}) {
3504 my $date = rfc822_date();
3505 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3506 variables => {request_addr => $param{request_addr},
3507 requester => $param{requester},
3513 if (not defined $action) {
3514 carp "Undefined action!";
3515 $action = "unknown action";
3517 return (action => $action,
3518 hash_slice(%param,keys %append_action_options),
3522 =head2 __begin_control
3524 my %info = __begin_control(%param,
3526 command=>'unarchive');
3527 my ($debug,$transcript) = @info{qw(debug transcript)};
3528 my @data = @{$info{data}};
3529 my @bugs = @{$info{bugs}};
3532 Starts the process of modifying a bug; handles all of the generic
3533 things that almost every control request needs
3535 Returns a hash containing
3539 =item new_locks -- number of new locks taken out by this call
3541 =item debug -- the debug file handle
3543 =item transcript -- the transcript file handle
3545 =item data -- an arrayref containing the data of the bugs
3546 corresponding to this request
3548 =item bugs -- an arrayref containing the bug numbers of the bugs
3549 corresponding to this request
3557 sub __begin_control {
3558 my %param = validate_with(params => \@_,
3559 spec => {bug => {type => SCALAR,
3562 archived => {type => BOOLEAN,
3565 command => {type => SCALAR,
3573 my ($debug,$transcript) = __handle_debug_transcript(@_);
3574 print {$debug} "$param{bug} considering\n";
3575 $lockhash = $param{locks} if exists $param{locks};
3577 my $old_die = $SIG{__DIE__};
3578 $SIG{__DIE__} = *sig_die{CODE};
3580 ($new_locks, @data) =
3581 lock_read_all_merged_bugs(bug => $param{bug},
3582 $param{archived}?(location => 'archive'):(),
3583 exists $param{locks} ? (locks => $param{locks}):(),
3585 $locks += $new_locks;
3587 die "Unable to read any bugs successfully.";
3589 if (not $param{archived}) {
3590 for my $data (@data) {
3591 if ($data->{archived}) {
3592 die "Not altering archived bugs; see unarchive.";
3596 if (not __check_limit(data => \@data,
3597 exists $param{limit}?(limit => $param{limit}):(),
3598 transcript => $transcript,
3600 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3603 __handle_affected_packages(%param,data => \@data);
3604 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3605 print {$debug} "$param{bug} read $locks locks\n";
3606 if (not @data or not defined $data[0]) {
3607 print {$transcript} "No bug found for $param{bug}\n";
3608 die "No bug found for $param{bug}";
3611 add_recipients(data => \@data,
3612 recipients => $param{recipients},
3613 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3615 (__internal_request()?(transcript => $transcript):()),
3618 print {$debug} "$param{bug} read done\n";
3619 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3620 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3621 return (data => \@data,
3623 old_die => $old_die,
3624 new_locks => $new_locks,
3626 transcript => $transcript,
3628 exists $param{locks}?(locks => $param{locks}):(),
3632 =head2 __end_control
3634 __end_control(%info);
3636 Handles tearing down from a control request
3642 if (exists $info{new_locks} and $info{new_locks} > 0) {
3643 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3644 for (1..$info{new_locks}) {
3645 unfilelock(exists $info{locks}?$info{locks}:());
3649 $SIG{__DIE__} = $info{old_die};
3650 if (exists $info{param}{affected_bugs}) {
3651 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3653 add_recipients(recipients => $info{param}{recipients},
3654 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3655 data => $info{data},
3656 debug => $info{debug},
3657 transcript => $info{transcript},
3659 __handle_affected_packages(%{$info{param}},data=>$info{data});
3663 =head2 __check_limit
3665 __check_limit(data => \@data, limit => $param{limit});
3668 Checks to make sure that bugs match any limits; each entry of @data
3669 much satisfy the limit.
3671 Returns true if there are no entries in data, or there are no keys in
3672 limit; returns false (0) if there are any entries which do not match.
3674 The limit hashref elements can contain an arrayref of scalars to
3675 match; regexes are also acccepted. At least one of the entries in each
3676 element needs to match the corresponding field in all data for the
3683 my %param = validate_with(params => \@_,
3684 spec => {data => {type => ARRAYREF|SCALAR,
3686 limit => {type => HASHREF|UNDEF,
3688 transcript => {type => SCALARREF|HANDLE,
3693 my @data = make_list($param{data});
3695 not defined $param{limit} or
3696 not keys %{$param{limit}}) {
3699 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3700 my $going_to_fail = 0;
3701 for my $data (@data) {
3702 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3703 status => dclone($data),
3705 for my $field (keys %{$param{limit}}) {
3706 next unless exists $param{limit}{$field};
3708 my @data_fields = make_list($data->{$field});
3709 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3710 if (not ref $limit) {
3711 for my $data_field (@data_fields) {
3712 if ($data_field eq $limit) {
3718 elsif (ref($limit) eq 'Regexp') {
3719 for my $data_field (@data_fields) {
3720 if ($data_field =~ $limit) {
3727 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3732 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3733 "' does not match at least one of ".
3734 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3738 return $going_to_fail?0:1;
3746 We override die to specially handle unlocking files in the cases where
3747 we are called via eval. [If we're not called via eval, it doesn't
3753 if ($^S) { # in eval
3755 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3762 # =head2 __message_body_template
3764 # message_body_template('mail/ack',{ref=>'foo'});
3766 # Creates a message body using a template
3770 sub __message_body_template{
3771 my ($template,$extra_var) = @_;
3773 my $hole_var = {'&bugurl' =>
3775 'http://'.$config{cgi_domain}.'/'.
3776 Debbugs::CGI::bug_url($_[0]);
3780 my $body = fill_in_template(template => $template,
3781 variables => {config => \%config,
3784 hole_var => $hole_var,
3786 return fill_in_template(template => 'mail/message_body',
3787 variables => {config => \%config,
3791 hole_var => $hole_var,
3795 sub __all_undef_or_equal {
3797 return 1 if @values == 1 or @values == 0;
3798 my $not_def = grep {not defined $_} @values;
3799 if ($not_def == @values) {
3802 if ($not_def > 0 and $not_def != @values) {
3805 my $first_val = shift @values;
3806 for my $val (@values) {
3807 if ($first_val ne $val) {