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 archive => [qw(bug_archive bug_unarchive),
101 log => [qw(append_action_to_log),
105 Exporter::export_ok_tags(keys %EXPORT_TAGS);
106 $EXPORT_TAGS{all} = [@EXPORT_OK];
109 use Debbugs::Config qw(:config);
110 use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions);
111 use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages split_status_fields get_bug_status);
112 use Debbugs::CGI qw(html_escape);
113 use Debbugs::Log qw(:misc :write);
114 use Debbugs::Recipients qw(:add);
115 use Debbugs::Packages qw(:versions :mapping);
117 use Data::Dumper qw();
118 use Params::Validate qw(validate_with :types);
119 use File::Path qw(mkpath);
122 use Debbugs::Text qw(:templates);
124 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
125 use Debbugs::MIME qw(create_mime_message);
127 use Mail::RFC822::Address qw();
129 use POSIX qw(strftime);
131 use Storable qw(dclone nfreeze);
132 use List::Util qw(first max);
136 # These are a set of options which are common to all of these functions
138 my %common_options = (debug => {type => SCALARREF|HANDLE,
141 transcript => {type => SCALARREF|HANDLE,
144 affected_bugs => {type => HASHREF,
147 affected_packages => {type => HASHREF,
150 recipients => {type => HASHREF,
153 limit => {type => HASHREF,
156 show_bug_info => {type => BOOLEAN,
159 request_subject => {type => SCALAR,
160 default => 'Unknown Subject',
162 request_msgid => {type => SCALAR,
165 request_nn => {type => SCALAR,
168 request_replyto => {type => SCALAR,
171 locks => {type => HASHREF,
177 my %append_action_options =
178 (action => {type => SCALAR,
181 requester => {type => SCALAR,
184 request_addr => {type => SCALAR,
187 location => {type => SCALAR,
190 message => {type => SCALAR|ARRAYREF,
193 append_log => {type => BOOLEAN,
195 depends => [qw(requester request_addr),
199 # locks is both an append_action option, and a common option;
200 # it's ok for it to be in both places.
201 locks => {type => HASHREF,
209 # this is just a generic stub for Debbugs::Control functions.
214 # set_foo(bug => $ref,
215 # transcript => $transcript,
216 # ($dl > 0 ? (debug => $transcript):()),
217 # requester => $header{from},
218 # request_addr => $controlrequestaddr,
220 # affected_packages => \%affected_packages,
221 # recipients => \%recipients,
227 # print {$transcript} "Failed to set foo $ref bar: $@";
235 # my %param = validate_with(params => \@_,
236 # spec => {bug => {type => SCALAR,
237 # regex => qr/^\d+$/,
239 # # specific options here
241 # %append_action_options,
245 # __begin_control(%param,
248 # my ($debug,$transcript) =
249 # @info{qw(debug transcript)};
250 # my @data = @{$info{data}};
251 # my @bugs = @{$info{bugs}};
254 # for my $data (@data) {
255 # append_action_to_log(bug => $data->{bug_num},
257 # __return_append_to_log_options(
262 # if not exists $param{append_log} or $param{append_log};
263 # writebug($data->{bug_num},$data);
264 # print {$transcript} "$action\n";
266 # __end_control(%info);
273 set_block(bug => $ref,
274 transcript => $transcript,
275 ($dl > 0 ? (debug => $transcript):()),
276 requester => $header{from},
277 request_addr => $controlrequestaddr,
279 affected_packages => \%affected_packages,
280 recipients => \%recipients,
286 print {$transcript} "Failed to set blockers of $ref: $@";
289 Alters the set of bugs that block this bug from being fixed
291 This requires altering both this bug (and those it's merged with) as
292 well as the bugs that block this bug from being fixed (and those that
297 =item block -- scalar or arrayref of blocking bugs to set, add or remove
299 =item add -- if true, add blocking bugs
301 =item remove -- if true, remove blocking bugs
308 my %param = validate_with(params => \@_,
309 spec => {bug => {type => SCALAR,
312 # specific options here
313 block => {type => SCALAR|ARRAYREF,
316 add => {type => BOOLEAN,
319 remove => {type => BOOLEAN,
323 %append_action_options,
326 if ($param{add} and $param{remove}) {
327 croak "It's nonsensical to add and remove the same blocking bugs";
329 if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
330 croak "Invalid blocking bug(s):".
331 join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
337 elsif ($param{remove}) {
342 __begin_control(%param,
345 my ($debug,$transcript) =
346 @info{qw(debug transcript)};
347 my @data = @{$info{data}};
348 my @bugs = @{$info{bugs}};
351 # The first bit of this code is ugly, and should be cleaned up.
352 # Its purpose is to populate %removed_blockers and %add_blockers
353 # with all of the bugs that should be added or removed as blockers
354 # of all of the bugs which are merged with $param{bug}
357 for my $blocker (make_list($param{block})) {
358 next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
359 my $data = read_bug(bug=>$blocker,
361 if (defined $data and not $data->{archive}) {
362 $data = split_status_fields($data);
363 $ok_blockers{$blocker} = 1;
365 push @merged_bugs, make_list($data->{mergedwith});
366 @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
369 $bad_blockers{$blocker} = 1;
373 # throw an error if we are setting the blockers and there is a bad
375 if (keys %bad_blockers and $mode eq 'set') {
376 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
377 keys %ok_blockers?'':" and no known blocking bug(s)";
379 # if there are no ok blockers and we are not setting the blockers,
381 if (not keys %ok_blockers and $mode ne 'set') {
382 print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
383 if (keys %bad_blockers) {
384 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
386 __end_control(%info);
390 my @change_blockers = keys %ok_blockers;
392 my %removed_blockers;
395 my @blockers = map {split ' ', $_->{blockedby}} @data;
397 @blockers{@blockers} = (1) x @blockers;
399 # it is nonsensical for a bug to block itself (or a merged
400 # partner); We currently don't allow removal because we'd possibly
404 @bugs{@bugs} = (1) x @bugs;
405 for my $blocker (@change_blockers) {
406 if ($bugs{$blocker}) {
407 croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
410 @blockers = keys %blockers;
412 %removed_blockers = ();
413 for my $blocker (@change_blockers) {
414 next if exists $blockers{$blocker};
415 $blockers{$blocker} = 1;
416 $added_blockers{$blocker} = 1;
419 elsif ($param{remove}) {
420 %added_blockers = ();
421 for my $blocker (@change_blockers) {
422 next if exists $removed_blockers{$blocker};
423 delete $blockers{$blocker};
424 $removed_blockers{$blocker} = 1;
428 @removed_blockers{@blockers} = (1) x @blockers;
430 for my $blocker (@change_blockers) {
431 next if exists $blockers{$blocker};
432 $blockers{$blocker} = 1;
433 if (exists $removed_blockers{$blocker}) {
434 delete $removed_blockers{$blocker};
437 $added_blockers{$blocker} = 1;
441 my @new_blockers = keys %blockers;
442 for my $data (@data) {
443 my $old_data = dclone($data);
444 # remove blockers and/or add new ones as appropriate
445 if ($data->{blockedby} eq '') {
446 print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n";
448 print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n";
450 if ($data->{blocks} eq '') {
451 print {$transcript} "$data->{bug_num} was not blocking any bugs.\n";
453 print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n";
456 push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
457 push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers;
458 $action = ucfirst(join ('; ',@changed)) if @changed;
460 print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n"
461 unless __internal_request();
464 $data->{blockedby} = join(' ',keys %blockers);
465 append_action_to_log(bug => $data->{bug_num},
467 old_data => $old_data,
470 __return_append_to_log_options(
475 if not exists $param{append_log} or $param{append_log};
476 writebug($data->{bug_num},$data);
477 print {$transcript} "$action\n";
479 # we do this bit below to avoid code duplication
481 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
482 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
484 for my $add_remove (keys %mungable_blocks) {
488 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
489 next if $munge_blockers{$blocker};
490 my ($temp_locks, @blocking_data) =
491 lock_read_all_merged_bugs(bug => $blocker,
492 ($param{archived}?(location => 'archive'):()),
493 exists $param{locks}?(locks => $param{locks}):(),
495 $locks+= $temp_locks;
496 $new_locks+=$temp_locks;
497 if (not @blocking_data) {
498 for (1..$new_locks) {
499 unfilelock(exists $param{locks}?$param{locks}:());
502 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
504 for (map {$_->{bug_num}} @blocking_data) {
505 $munge_blockers{$_} = 1;
507 for my $data (@blocking_data) {
508 my $old_data = dclone($data);
510 my @blocks = split ' ', $data->{blocks};
511 @blocks{@blocks} = (1) x @blocks;
513 for my $bug (@bugs) {
514 if ($add_remove eq 'remove') {
515 next unless exists $blocks{$bug};
516 delete $blocks{$bug};
519 next if exists $blocks{$bug};
524 $data->{blocks} = join(' ',sort keys %blocks);
525 my $action = ($add_remove eq 'add'?'Added':'Removed').
526 " indication that bug $data->{bug_num} blocks ".
528 append_action_to_log(bug => $data->{bug_num},
530 old_data => $old_data,
533 __return_append_to_log_options(%param,
537 writebug($data->{bug_num},$data);
539 __handle_affected_packages(%param,data=>\@blocking_data);
540 add_recipients(recipients => $param{recipients},
541 actions_taken => {blocks => 1},
542 data => \@blocking_data,
544 transcript => $transcript,
547 for (1..$new_locks) {
548 unfilelock(exists $param{locks}?$param{locks}:());
553 __end_control(%info);
562 transcript => $transcript,
563 ($dl > 0 ? (debug => $transcript):()),
564 requester => $header{from},
565 request_addr => $controlrequestaddr,
567 affected_packages => \%affected_packages,
568 recipients => \%recipients,
575 print {$transcript} "Failed to set tag on $ref: $@";
579 Sets, adds, or removes the specified tags on a bug
583 =item tag -- scalar or arrayref of tags to set, add or remove
585 =item add -- if true, add tags
587 =item remove -- if true, remove tags
589 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
597 my %param = validate_with(params => \@_,
598 spec => {bug => {type => SCALAR,
601 # specific options here
602 tag => {type => SCALAR|ARRAYREF,
605 add => {type => BOOLEAN,
608 remove => {type => BOOLEAN,
611 warn_on_bad_tags => {type => BOOLEAN,
615 %append_action_options,
618 if ($param{add} and $param{remove}) {
619 croak "It's nonsensical to add and remove the same tags";
623 __begin_control(%param,
626 my ($debug,$transcript) =
627 @info{qw(debug transcript)};
628 my @data = @{$info{data}};
629 my @bugs = @{$info{bugs}};
630 my @tags = make_list($param{tag});
631 if (not @tags and ($param{remove} or $param{add})) {
632 if ($param{remove}) {
633 print {$transcript} "Requested to remove no tags; doing nothing.\n";
636 print {$transcript} "Requested to add no tags; doing nothing.\n";
638 __end_control(%info);
641 # first things first, make the versions fully qualified source
643 for my $data (@data) {
644 my $action = 'Did not alter tags';
646 my %tag_removed = ();
647 my %fixed_removed = ();
648 my @old_tags = split /\,?\s+/, $data->{keywords};
650 @tags{@old_tags} = (1) x @old_tags;
652 my $old_data = dclone($data);
653 if (not $param{add} and not $param{remove}) {
654 $tag_removed{$_} = 1 for @old_tags;
658 for my $tag (@tags) {
659 if (not $param{remove} and
660 not defined first {$_ eq $tag} @{$config{tags}}) {
661 push @bad_tags, $tag;
665 if (not exists $tags{$tag}) {
667 $tag_added{$tag} = 1;
670 elsif ($param{remove}) {
671 if (exists $tags{$tag}) {
673 $tag_removed{$tag} = 1;
677 if (exists $tag_removed{$tag}) {
678 delete $tag_removed{$tag};
681 $tag_added{$tag} = 1;
686 if (@bad_tags and $param{warn_on_bad_tags}) {
687 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
688 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
690 $data->{keywords} = join(' ',keys %tags);
693 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
694 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
695 $action = ucfirst(join ('; ',@changed)) if @changed;
697 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
698 unless __internal_request();
702 append_action_to_log(bug => $data->{bug_num},
705 old_data => $old_data,
707 __return_append_to_log_options(
712 if not exists $param{append_log} or $param{append_log};
713 writebug($data->{bug_num},$data);
714 print {$transcript} "$action\n";
716 __end_control(%info);
724 set_severity(bug => $ref,
725 transcript => $transcript,
726 ($dl > 0 ? (debug => $transcript):()),
727 requester => $header{from},
728 request_addr => $controlrequestaddr,
730 affected_packages => \%affected_packages,
731 recipients => \%recipients,
732 severity => 'normal',
737 print {$transcript} "Failed to set the severity of bug $ref: $@";
740 Sets the severity of a bug. If severity is not passed, is undefined,
741 or has zero length, sets the severity to the default severity.
746 my %param = validate_with(params => \@_,
747 spec => {bug => {type => SCALAR,
750 # specific options here
751 severity => {type => SCALAR|UNDEF,
752 default => $config{default_severity},
755 %append_action_options,
758 if (not defined $param{severity} or
759 not length $param{severity}
761 $param{severity} = $config{default_severity};
764 # check validity of new severity
765 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
766 die "Severity '$param{severity}' is not a valid severity level";
769 __begin_control(%param,
770 command => 'severity'
772 my ($debug,$transcript) =
773 @info{qw(debug transcript)};
774 my @data = @{$info{data}};
775 my @bugs = @{$info{bugs}};
778 for my $data (@data) {
779 if (not defined $data->{severity}) {
780 $data->{severity} = $param{severity};
781 $action = "Severity set to '$param{severity}'";
784 if ($data->{severity} eq '') {
785 $data->{severity} = $config{default_severity};
787 if ($data->{severity} eq $param{severity}) {
788 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
791 $action = "Severity set to '$param{severity}' from '$data->{severity}'";
792 $data->{severity} = $param{severity};
794 append_action_to_log(bug => $data->{bug_num},
796 __return_append_to_log_options(
801 if not exists $param{append_log} or $param{append_log};
802 writebug($data->{bug_num},$data);
803 print {$transcript} "$action\n";
805 __end_control(%info);
812 set_done(bug => $ref,
813 transcript => $transcript,
814 ($dl > 0 ? (debug => $transcript):()),
815 requester => $header{from},
816 request_addr => $controlrequestaddr,
818 affected_packages => \%affected_packages,
819 recipients => \%recipients,
824 print {$transcript} "Failed to set foo $ref bar: $@";
832 my %param = validate_with(params => \@_,
833 spec => {bug => {type => SCALAR,
836 reopen => {type => BOOLEAN,
839 submitter => {type => SCALAR,
842 clear_fixed => {type => BOOLEAN,
845 notify_submitter => {type => BOOLEAN,
848 original_report => {type => SCALARREF,
851 done => {type => SCALAR|UNDEF,
855 %append_action_options,
859 if (exists $param{submitter} and
860 not Mail::RFC822::Address::valid($param{submitter})) {
861 die "New submitter address '$param{submitter}' is not a valid e-mail address";
863 if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address
864 $param{done} = $param{requester};
866 if (exists $param{done} and
867 (not defined $param{done} or
868 not length $param{done})) {
874 __begin_control(%param,
875 command => $param{reopen}?'reopen':'done',
877 my ($debug,$transcript) =
878 @info{qw(debug transcript)};
879 my @data = @{$info{data}};
880 my @bugs = @{$info{bugs}};
883 if ($param{reopen}) {
884 # avoid warning multiple times if there are fixed versions
886 for my $data (@data) {
887 if (not exists $data->{done} or
888 not defined $data->{done} or
889 not length $data->{done}) {
890 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
891 __end_control(%info);
894 if (@{$data->{fixed_versions}} and $warn_fixed) {
895 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
896 print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n";
900 $action = "Bug reopened";
901 for my $data (@data) {
902 my $old_data = dclone($data);
904 append_action_to_log(bug => $data->{bug_num},
907 old_data => $old_data,
909 __return_append_to_log_options(
914 if not exists $param{append_log} or $param{append_log};
915 writebug($data->{bug_num},$data);
917 print {$transcript} "$action\n";
918 __end_control(%info);
919 if (exists $param{submitter}) {
920 set_submitter(bug => $param{bug},
921 submitter => $param{submitter},
923 keys %common_options,
924 keys %append_action_options)
927 # clear the fixed revisions
928 if ($param{clear_fixed}) {
929 set_fixed(fixed => [],
933 keys %common_options,
934 keys %append_action_options),
939 my %submitter_notified;
940 my $requester_notified = 0;
941 my $orig_report_set = 0;
942 for my $data (@data) {
943 if (exists $data->{done} and
944 defined $data->{done} and
945 length $data->{done}) {
946 print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
947 __end_control(%info);
951 for my $data (@data) {
952 my $old_data = dclone($data);
953 my $hash = get_hashname($data->{bug_num});
954 my $report_fh = IO::File->new("db-h/$hash/$data->{bug_num}.report",'r') or
955 die "Unable to open original report db-h/$hash/$data->{bug_num}.report for reading: $!";
959 $orig_report= <$report_fh>;
962 if (not $orig_report_set and defined $orig_report and
963 length $orig_report and
964 exists $param{original_report}){
965 ${$param{original_report}} = $orig_report;
966 $orig_report_set = 1;
969 $action = "Marked $config{bug} as done";
971 # set done to the requester
972 $data->{done} = exists $param{done}?$param{done}:$param{requester};
973 append_action_to_log(bug => $data->{bug_num},
976 old_data => $old_data,
978 __return_append_to_log_options(
983 if not exists $param{append_log} or $param{append_log};
984 writebug($data->{bug_num},$data);
985 print {$transcript} "$action\n";
986 # get the original report
987 if ($param{notify_submitter}) {
988 my $submitter_message;
989 if(not exists $submitter_notified{$data->{originator}}) {
991 create_mime_message([default_headers(queue_file => $param{request_nn},
993 msgid => $param{request_msgid},
994 msgtype => 'notifdone',
995 pr_msg => 'they-closed',
997 [To => $data->{submitter},
998 Subject => "$config{ubug}#$data->{bug_num} ".
999 "closed by $param{requester} ($param{request_subject})",
1003 __message_body_template('mail/process_your_bug_done',
1005 replyto => (exists $param{request_replyto} ?
1006 $param{request_replyto} :
1007 $param{requester} || 'Unknown'),
1008 markedby => $param{requester},
1009 subject => $param{request_subject},
1010 messageid => $param{request_msgid},
1013 [join('',make_list($param{message})),$orig_report]
1015 send_mail_message(message => $submitter_message,
1016 recipients => $old_data->{submitter},
1018 $submitter_notified{$data->{originator}} = $submitter_message;
1021 $submitter_message = $submitter_notified{$data->{originator}};
1023 append_action_to_log(bug => $data->{bug_num},
1024 action => "Notification sent",
1026 request_addr => $data->{originator},
1027 desc => "$config{bug} acknowledged by developer.",
1028 recips => [$data->{originator}],
1029 message => $submitter_message,
1034 __end_control(%info);
1035 if (exists $param{fixed}) {
1036 set_fixed(fixed => $param{fixed},
1040 keys %common_options,
1041 keys %append_action_options
1049 =head2 set_submitter
1052 set_submitter(bug => $ref,
1053 transcript => $transcript,
1054 ($dl > 0 ? (debug => $transcript):()),
1055 requester => $header{from},
1056 request_addr => $controlrequestaddr,
1058 affected_packages => \%affected_packages,
1059 recipients => \%recipients,
1060 submitter => $new_submitter,
1061 notify_submitter => 1,
1066 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1069 Sets the submitter of a bug. If notify_submitter is true (the
1070 default), notifies the old submitter of a bug on changes
1075 my %param = validate_with(params => \@_,
1076 spec => {bug => {type => SCALAR,
1079 # specific options here
1080 submitter => {type => SCALAR,
1082 notify_submitter => {type => BOOLEAN,
1086 %append_action_options,
1089 if (not Mail::RFC822::Address::valid($param{submitter})) {
1090 die "New submitter address $param{submitter} is not a valid e-mail address";
1093 __begin_control(%param,
1094 command => 'submitter'
1096 my ($debug,$transcript) =
1097 @info{qw(debug transcript)};
1098 my @data = @{$info{data}};
1099 my @bugs = @{$info{bugs}};
1101 # here we only concern ourselves with the first of the merged bugs
1102 for my $data ($data[0]) {
1103 my $notify_old_submitter = 0;
1104 my $old_data = dclone($data);
1105 print {$debug} "Going to change bug submitter\n";
1106 if (((not defined $param{submitter} or not length $param{submitter}) and
1107 (not defined $data->{originator} or not length $data->{originator})) or
1108 (defined $param{submitter} and defined $data->{originator} and
1109 $param{submitter} eq $data->{originator})) {
1110 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
1111 unless __internal_request();
1115 if (defined $data->{originator} and length($data->{originator})) {
1116 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
1117 $notify_old_submitter = 1;
1120 $action= "Set $config{bug} submitter to '$param{submitter}'.";
1122 $data->{originator} = $param{submitter};
1124 append_action_to_log(bug => $data->{bug_num},
1125 command => 'submitter',
1127 old_data => $old_data,
1129 __return_append_to_log_options(
1134 if not exists $param{append_log} or $param{append_log};
1135 writebug($data->{bug_num},$data);
1136 print {$transcript} "$action\n";
1137 # notify old submitter
1138 if ($notify_old_submitter and $param{notify_submitter}) {
1139 send_mail_message(message =>
1140 create_mime_message([default_headers(queue_file => $param{request_nn},
1142 msgid => $param{request_msgid},
1144 pr_msg => 'submitter-changed',
1146 [To => $old_data->{submitter},
1147 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
1151 __message_body_template('mail/submitter_changed',
1152 {old_data => $old_data,
1154 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
1158 recipients => $old_data->{submitter},
1162 __end_control(%info);
1167 =head2 set_forwarded
1170 set_forwarded(bug => $ref,
1171 transcript => $transcript,
1172 ($dl > 0 ? (debug => $transcript):()),
1173 requester => $header{from},
1174 request_addr => $controlrequestaddr,
1176 affected_packages => \%affected_packages,
1177 recipients => \%recipients,
1178 forwarded => $forward_to,
1183 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1186 Sets the location to which a bug is forwarded. Given an undef
1187 forwarded, unsets forwarded.
1193 my %param = validate_with(params => \@_,
1194 spec => {bug => {type => SCALAR,
1197 # specific options here
1198 forwarded => {type => SCALAR|UNDEF,
1201 %append_action_options,
1204 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1205 die "Non-printable characters are not allowed in the forwarded field";
1207 $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
1209 __begin_control(%param,
1210 command => 'forwarded'
1212 my ($debug,$transcript) =
1213 @info{qw(debug transcript)};
1214 my @data = @{$info{data}};
1215 my @bugs = @{$info{bugs}};
1217 for my $data (@data) {
1218 my $old_data = dclone($data);
1219 print {$debug} "Going to change bug forwarded\n";
1220 if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
1221 (not defined $param{forwarded} and
1222 defined $data->{forwarded} and not length $data->{forwarded})) {
1223 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1224 unless __internal_request();
1228 if (not defined $param{forwarded}) {
1229 $action= "Unset $config{bug} forwarded-to-address";
1231 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1232 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1235 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1237 $data->{forwarded} = $param{forwarded};
1239 append_action_to_log(bug => $data->{bug_num},
1240 command => 'forwarded',
1242 old_data => $old_data,
1244 __return_append_to_log_options(
1249 if not exists $param{append_log} or $param{append_log};
1250 writebug($data->{bug_num},$data);
1251 print {$transcript} "$action\n";
1253 __end_control(%info);
1262 set_title(bug => $ref,
1263 transcript => $transcript,
1264 ($dl > 0 ? (debug => $transcript):()),
1265 requester => $header{from},
1266 request_addr => $controlrequestaddr,
1268 affected_packages => \%affected_packages,
1269 recipients => \%recipients,
1270 title => $new_title,
1275 print {$transcript} "Failed to set the title of $ref: $@";
1278 Sets the title of a specific bug
1284 my %param = validate_with(params => \@_,
1285 spec => {bug => {type => SCALAR,
1288 # specific options here
1289 title => {type => SCALAR,
1292 %append_action_options,
1295 if ($param{title} =~ /[^[:print:]]/) {
1296 die "Non-printable characters are not allowed in bug titles";
1299 my %info = __begin_control(%param,
1302 my ($debug,$transcript) =
1303 @info{qw(debug transcript)};
1304 my @data = @{$info{data}};
1305 my @bugs = @{$info{bugs}};
1307 for my $data (@data) {
1308 my $old_data = dclone($data);
1309 print {$debug} "Going to change bug title\n";
1310 if (defined $data->{subject} and length($data->{subject}) and
1311 $data->{subject} eq $param{title}) {
1312 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1313 unless __internal_request();
1317 if (defined $data->{subject} and length($data->{subject})) {
1318 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1320 $action= "Set $config{bug} title to '$param{title}'.";
1322 $data->{subject} = $param{title};
1324 append_action_to_log(bug => $data->{bug_num},
1327 old_data => $old_data,
1329 __return_append_to_log_options(
1334 if not exists $param{append_log} or $param{append_log};
1335 writebug($data->{bug_num},$data);
1336 print {$transcript} "$action\n";
1338 __end_control(%info);
1345 set_package(bug => $ref,
1346 transcript => $transcript,
1347 ($dl > 0 ? (debug => $transcript):()),
1348 requester => $header{from},
1349 request_addr => $controlrequestaddr,
1351 affected_packages => \%affected_packages,
1352 recipients => \%recipients,
1353 package => $new_package,
1359 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1362 Indicates that a bug is in a particular package. If is_source is true,
1363 indicates that the package is a source package. [Internally, this
1364 causes src: to be prepended to the package name.]
1366 The default for is_source is 0. As a special case, if the package
1367 starts with 'src:', it is assumed to be a source package and is_source
1370 The package option must match the package_name_re regex.
1375 my %param = validate_with(params => \@_,
1376 spec => {bug => {type => SCALAR,
1379 # specific options here
1380 package => {type => SCALAR|ARRAYREF,
1382 is_source => {type => BOOLEAN,
1386 %append_action_options,
1389 my @new_packages = map {splitpackages($_)} make_list($param{package});
1390 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1391 croak "Invalid package name '".
1392 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1395 my %info = __begin_control(%param,
1396 command => 'package',
1398 my ($debug,$transcript) =
1399 @info{qw(debug transcript)};
1400 my @data = @{$info{data}};
1401 my @bugs = @{$info{bugs}};
1402 # clean up the new package
1406 ($temp =~ s/^src:// or
1407 $param{is_source}) ? 'src:'.$temp:$temp;
1411 my $package_reassigned = 0;
1412 for my $data (@data) {
1413 my $old_data = dclone($data);
1414 print {$debug} "Going to change assigned package\n";
1415 if (defined $data->{package} and length($data->{package}) and
1416 $data->{package} eq $new_package) {
1417 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1418 unless __internal_request();
1422 if (defined $data->{package} and length($data->{package})) {
1423 $package_reassigned = 1;
1424 $action= "$config{bug} reassigned from package '$data->{package}'".
1425 " to '$new_package'.";
1427 $action= "$config{bug} assigned to package '$new_package'.";
1429 $data->{package} = $new_package;
1431 append_action_to_log(bug => $data->{bug_num},
1432 command => 'package',
1434 old_data => $old_data,
1436 __return_append_to_log_options(
1441 if not exists $param{append_log} or $param{append_log};
1442 writebug($data->{bug_num},$data);
1443 print {$transcript} "$action\n";
1445 __end_control(%info);
1446 # Only clear the fixed/found versions if the package has been
1448 if ($package_reassigned) {
1449 my @params_for_found_fixed =
1450 map {exists $param{$_}?($_,$param{$_}):()}
1452 keys %common_options,
1453 keys %append_action_options,
1455 set_found(found => [],
1456 @params_for_found_fixed,
1458 set_fixed(fixed => [],
1459 @params_for_found_fixed,
1467 set_found(bug => $ref,
1468 transcript => $transcript,
1469 ($dl > 0 ? (debug => $transcript):()),
1470 requester => $header{from},
1471 request_addr => $controlrequestaddr,
1473 affected_packages => \%affected_packages,
1474 recipients => \%recipients,
1481 print {$transcript} "Failed to set found on $ref: $@";
1485 Sets, adds, or removes the specified found versions of a package
1487 If the version list is empty, and the bug is currently not "done",
1488 causes the done field to be cleared.
1490 If any of the versions added to found are greater than any version in
1491 which the bug is fixed (or when the bug is found and there are no
1492 fixed versions) the done field is cleared.
1497 my %param = validate_with(params => \@_,
1498 spec => {bug => {type => SCALAR,
1501 # specific options here
1502 found => {type => SCALAR|ARRAYREF,
1505 add => {type => BOOLEAN,
1508 remove => {type => BOOLEAN,
1512 %append_action_options,
1515 if ($param{add} and $param{remove}) {
1516 croak "It's nonsensical to add and remove the same versions";
1520 __begin_control(%param,
1523 my ($debug,$transcript) =
1524 @info{qw(debug transcript)};
1525 my @data = @{$info{data}};
1526 my @bugs = @{$info{bugs}};
1528 for my $version (make_list($param{found})) {
1529 next unless defined $version;
1530 $versions{$version} =
1531 [make_source_versions(package => [splitpackages($data[0]{package})],
1532 warnings => $transcript,
1535 versions => $version,
1538 # This is really ugly, but it's what we have to do
1539 if (not @{$versions{$version}}) {
1540 print {$transcript} "Unable to make a source version for version '$version'\n";
1543 if (not keys %versions and ($param{remove} or $param{add})) {
1544 if ($param{remove}) {
1545 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1548 print {$transcript} "Requested to add no versions; doing nothing.\n";
1550 __end_control(%info);
1553 # first things first, make the versions fully qualified source
1555 for my $data (@data) {
1556 # The 'done' field gets a bit weird with version tracking,
1557 # because a bug may be closed by multiple people in different
1558 # branches. Until we have something more flexible, we set it
1559 # every time a bug is fixed, and clear it when a bug is found
1560 # in a version greater than any version in which the bug is
1561 # fixed or when a bug is found and there is no fixed version
1562 my $action = 'Did not alter found versions';
1563 my %found_added = ();
1564 my %found_removed = ();
1565 my %fixed_removed = ();
1567 my $old_data = dclone($data);
1568 if (not $param{add} and not $param{remove}) {
1569 $found_removed{$_} = 1 for @{$data->{found_versions}};
1570 $data->{found_versions} = [];
1573 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1575 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1576 for my $version (keys %versions) {
1578 my @svers = @{$versions{$version}};
1582 for my $sver (@svers) {
1583 if (not exists $found_versions{$sver}) {
1584 $found_versions{$sver} = 1;
1585 $found_added{$sver} = 1;
1587 # if the found we are adding matches any fixed
1588 # versions, remove them
1589 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1590 delete $fixed_versions{$_} for @temp;
1591 $fixed_removed{$_} = 1 for @temp;
1594 # We only care about reopening the bug if the bug is
1596 if (defined $data->{done} and length $data->{done}) {
1597 my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
1599 # determine if we need to reopen
1600 my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
1601 keys %fixed_versions);
1602 if (not @fixed_order or
1603 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1609 elsif ($param{remove}) {
1610 # in the case of removal, we only concern ourself with
1611 # the version passed, not the source version it maps
1613 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1614 delete $found_versions{$_} for @temp;
1615 $found_removed{$_} = 1 for @temp;
1618 # set the keys to exactly these values
1619 my @svers = @{$versions{$version}};
1623 for my $sver (@svers) {
1624 if (not exists $found_versions{$sver}) {
1625 $found_versions{$sver} = 1;
1626 if (exists $found_removed{$sver}) {
1627 delete $found_removed{$sver};
1630 $found_added{$sver} = 1;
1637 $data->{found_versions} = [keys %found_versions];
1638 $data->{fixed_versions} = [keys %fixed_versions];
1641 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1642 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1643 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1644 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1645 $action = ucfirst(join ('; ',@changed)) if @changed;
1647 $action .= " and reopened"
1649 if (not $reopened and not @changed) {
1650 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1651 unless __internal_request();
1655 append_action_to_log(bug => $data->{bug_num},
1658 old_data => $old_data,
1660 __return_append_to_log_options(
1665 if not exists $param{append_log} or $param{append_log};
1666 writebug($data->{bug_num},$data);
1667 print {$transcript} "$action\n";
1669 __end_control(%info);
1675 set_fixed(bug => $ref,
1676 transcript => $transcript,
1677 ($dl > 0 ? (debug => $transcript):()),
1678 requester => $header{from},
1679 request_addr => $controlrequestaddr,
1681 affected_packages => \%affected_packages,
1682 recipients => \%recipients,
1690 print {$transcript} "Failed to set fixed on $ref: $@";
1694 Sets, adds, or removes the specified fixed versions of a package
1696 If the fixed versions are empty (or end up being empty after this
1697 call) or the greatest fixed version is less than the greatest found
1698 version and the reopen option is true, the bug is reopened.
1700 This function is also called by the reopen function, which causes all
1701 of the fixed versions to be cleared.
1706 my %param = validate_with(params => \@_,
1707 spec => {bug => {type => SCALAR,
1710 # specific options here
1711 fixed => {type => SCALAR|ARRAYREF,
1714 add => {type => BOOLEAN,
1717 remove => {type => BOOLEAN,
1720 reopen => {type => BOOLEAN,
1724 %append_action_options,
1727 if ($param{add} and $param{remove}) {
1728 croak "It's nonsensical to add and remove the same versions";
1731 __begin_control(%param,
1734 my ($debug,$transcript) =
1735 @info{qw(debug transcript)};
1736 my @data = @{$info{data}};
1737 my @bugs = @{$info{bugs}};
1739 for my $version (make_list($param{fixed})) {
1740 next unless defined $version;
1741 $versions{$version} =
1742 [make_source_versions(package => [splitpackages($data[0]{package})],
1743 warnings => $transcript,
1746 versions => $version,
1749 # This is really ugly, but it's what we have to do
1750 if (not @{$versions{$version}}) {
1751 print {$transcript} "Unable to make a source version for version '$version'\n";
1754 if (not keys %versions and ($param{remove} or $param{add})) {
1755 if ($param{remove}) {
1756 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1759 print {$transcript} "Requested to add no versions; doing nothing.\n";
1761 __end_control(%info);
1764 # first things first, make the versions fully qualified source
1766 for my $data (@data) {
1767 my $old_data = dclone($data);
1768 # The 'done' field gets a bit weird with version tracking,
1769 # because a bug may be closed by multiple people in different
1770 # branches. Until we have something more flexible, we set it
1771 # every time a bug is fixed, and clear it when a bug is found
1772 # in a version greater than any version in which the bug is
1773 # fixed or when a bug is found and there is no fixed version
1774 my $action = 'Did not alter fixed versions';
1775 my %found_added = ();
1776 my %found_removed = ();
1777 my %fixed_added = ();
1778 my %fixed_removed = ();
1780 if (not $param{add} and not $param{remove}) {
1781 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1782 $data->{fixed_versions} = [];
1785 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1787 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1788 for my $version (keys %versions) {
1790 my @svers = @{$versions{$version}};
1794 for my $sver (@svers) {
1795 if (not exists $fixed_versions{$sver}) {
1796 $fixed_versions{$sver} = 1;
1797 $fixed_added{$sver} = 1;
1801 elsif ($param{remove}) {
1802 # in the case of removal, we only concern ourself with
1803 # the version passed, not the source version it maps
1805 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1806 delete $fixed_versions{$_} for @temp;
1807 $fixed_removed{$_} = 1 for @temp;
1810 # set the keys to exactly these values
1811 my @svers = @{$versions{$version}};
1815 for my $sver (@svers) {
1816 if (not exists $fixed_versions{$sver}) {
1817 $fixed_versions{$sver} = 1;
1818 if (exists $fixed_removed{$sver}) {
1819 delete $fixed_removed{$sver};
1822 $fixed_added{$sver} = 1;
1829 $data->{found_versions} = [keys %found_versions];
1830 $data->{fixed_versions} = [keys %fixed_versions];
1832 # If we're supposed to consider reopening, reopen if the
1833 # fixed versions are empty or the greatest found version
1834 # is greater than the greatest fixed version
1835 if ($param{reopen} and defined $data->{done}
1836 and length $data->{done}) {
1837 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1838 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1839 # determine if we need to reopen
1840 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1841 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1842 if (not @fixed_order or
1843 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1850 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1851 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1852 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1853 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1854 $action = ucfirst(join ('; ',@changed)) if @changed;
1856 $action .= " and reopened"
1858 if (not $reopened and not @changed) {
1859 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1860 unless __internal_request();
1864 append_action_to_log(bug => $data->{bug_num},
1867 old_data => $old_data,
1869 __return_append_to_log_options(
1874 if not exists $param{append_log} or $param{append_log};
1875 writebug($data->{bug_num},$data);
1876 print {$transcript} "$action\n";
1878 __end_control(%info);
1885 set_merged(bug => $ref,
1886 transcript => $transcript,
1887 ($dl > 0 ? (debug => $transcript):()),
1888 requester => $header{from},
1889 request_addr => $controlrequestaddr,
1891 affected_packages => \%affected_packages,
1892 recipients => \%recipients,
1893 merge_with => 12345,
1896 allow_reassign => 1,
1897 reassign_same_source_only => 1,
1902 print {$transcript} "Failed to set merged on $ref: $@";
1906 Sets, adds, or removes the specified merged bugs of a bug
1908 By default, requires
1913 my %param = validate_with(params => \@_,
1914 spec => {bug => {type => SCALAR,
1917 # specific options here
1918 merge_with => {type => ARRAYREF|SCALAR,
1921 remove => {type => BOOLEAN,
1924 force => {type => BOOLEAN,
1927 masterbug => {type => BOOLEAN,
1930 allow_reassign => {type => BOOLEAN,
1933 reassign_different_sources => {type => BOOLEAN,
1937 %append_action_options,
1940 my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1942 @merging{@merging} = (1) x @merging;
1943 if (grep {$_ !~ /^\d+$/} @merging) {
1944 croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1946 $param{locks} = {} if not exists $param{locks};
1948 __begin_control(%param,
1951 my ($debug,$transcript) =
1952 @info{qw(debug transcript)};
1953 if (not @merging and exists $param{merge_with}) {
1954 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1955 __end_control(%info);
1958 my @data = @{$info{data}};
1959 my @bugs = @{$info{bugs}};
1962 for my $data (@data) {
1963 $data{$data->{bug_num}} = $data;
1964 my @merged_bugs = split / /, $data->{mergedwith};
1965 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1969 if (not exists $param{merge_with}) {
1970 my $ok_to_unmerge = 1;
1971 delete $merged_bugs{$param{bug}};
1972 if (not keys %merged_bugs) {
1973 print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1974 __end_control(%info);
1977 my $action = "Disconnected #$param{bug} from all other report(s).";
1978 for my $data (@data) {
1979 my $old_data = dclone($data);
1980 if ($data->{bug_num} == $param{bug}) {
1981 $data->{mergedwith} = '';
1984 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
1987 append_action_to_log(bug => $data->{bug_num},
1990 old_data => $old_data,
1992 __return_append_to_log_options(%param,
1996 if not exists $param{append_log} or $param{append_log};
1997 writebug($data->{bug_num},$data);
1999 print {$transcript} "$action\n";
2000 __end_control(%info);
2003 # lock and load all of the bugs we need
2004 my @bugs_to_load = keys %merging;
2007 my ($data,$n_locks) =
2008 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2010 locks => $param{locks},
2013 $new_locks += $n_locks;
2015 @data = values %data;
2016 if (not __check_limit(data => [@data],
2017 exists $param{limit}?(limit => $param{limit}):(),
2018 transcript => $transcript,
2020 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2022 for my $data (@data) {
2023 $data{$data->{bug_num}} = $data;
2024 $merged_bugs{$data->{bug_num}} = 1;
2025 my @merged_bugs = split / /, $data->{mergedwith};
2026 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2027 if (exists $param{affected_bugs}) {
2028 $param{affected_bugs}{$data->{bug_num}} = 1;
2031 __handle_affected_packages(%param,data => [@data]);
2032 my %bug_info_shown; # which bugs have had information shown
2033 $bug_info_shown{$param{bug}} = 1;
2034 add_recipients(data => [@data],
2035 recipients => $param{recipients},
2036 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2038 (__internal_request()?(transcript => $transcript):()),
2041 # Figure out what the ideal state is for the bug,
2042 my ($merge_status,$bugs_to_merge) =
2043 __calculate_merge_status(\@data,\%data,$param{bug});
2044 # find out if we actually have any bugs to merge
2045 if (not $bugs_to_merge) {
2046 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2047 for (1..$new_locks) {
2048 unfilelock($param{locks});
2051 __end_control(%info);
2054 # see what changes need to be made to merge the bugs
2055 # check to make sure that the set of changes we need to make is allowed
2056 my ($disallowed_changes,$changes) =
2057 __calculate_merge_changes(\@data,$merge_status,\%param);
2058 # at this point, stop if there are disallowed changes, otherwise
2059 # make the allowed changes, and then reread the bugs in question
2060 # to get the new data, then recaculate the merges; repeat
2061 # reloading and recalculating until we try too many times or there
2062 # are no changes to make.
2065 # we will allow at most 4 times through this; more than 1
2066 # shouldn't really happen.
2068 while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2069 if ($attempts > 1) {
2070 print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2072 if (@{$disallowed_changes}) {
2073 # figure out the problems
2074 print {$transcript} "Unable to merge bugs because:\n";
2075 for my $change (@{$disallowed_changes}) {
2076 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{orig_value}' not '$change->{value}'\n";
2078 if ($attempts > 0) {
2079 croak "Some bugs were altered while attempting to merge";
2082 croak "Did not alter merged bugs";
2085 my ($change_bug) = keys %{$changes};
2086 $bug_changed{$change_bug}++;
2087 print {$transcript} __bug_info($data{$change_bug}) if
2088 $param{show_bug_info} and not __internal_request(1);
2089 $bug_info_shown{$change_bug} = 1;
2090 __allow_relocking($param{locks},[keys %data]);
2091 for my $change (@{$changes->{$change_bug}}) {
2092 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2093 my %target_blockedby;
2094 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2095 my %unhandled_targets = %target_blockedby;
2096 my @blocks_to_remove;
2097 for my $key (split / /,$change->{orig_value}) {
2098 delete $unhandled_targets{$key};
2099 next if exists $target_blockedby{$key};
2100 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2101 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2104 keys %common_options,
2105 keys %append_action_options),
2108 for my $key (keys %unhandled_targets) {
2109 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2110 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2113 keys %common_options,
2114 keys %append_action_options),
2119 $change->{function}->(bug => $change->{bug},
2120 $change->{key}, $change->{func_value},
2121 exists $change->{options}?@{$change->{options}}:(),
2123 keys %common_options,
2124 keys %append_action_options),
2128 __disallow_relocking($param{locks});
2129 my ($data,$n_locks) =
2130 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2132 locks => $param{locks},
2136 $new_locks += $n_locks;
2139 @data = values %data;
2140 ($merge_status,$bugs_to_merge) =
2141 __calculate_merge_status(\@data,\%data,$param{bug});
2142 ($disallowed_changes,$changes) =
2143 __calculate_merge_changes(\@data,$merge_status,\%param);
2144 $attempts = max(values %bug_changed);
2146 if ($param{show_bug_info} and not __internal_request(1)) {
2147 for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2148 next if $bug_info_shown{$data->{bug_num}};
2149 print {$transcript} __bug_info($data);
2152 if (keys %{$changes} or @{$disallowed_changes}) {
2153 print {$transcript} "Unable to modify bugs so that they could be merged\n";
2154 for (1..$new_locks) {
2155 unfilelock($param{locks});
2158 __end_control(%info);
2162 # finally, we can merge the bugs
2163 my $action = "Merged ".join(' ',sort keys %merged_bugs);
2164 for my $data (@data) {
2165 my $old_data = dclone($data);
2166 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2168 append_action_to_log(bug => $data->{bug_num},
2171 old_data => $old_data,
2173 __return_append_to_log_options(%param,
2177 if not exists $param{append_log} or $param{append_log};
2178 writebug($data->{bug_num},$data);
2180 print {$transcript} "$action\n";
2181 # unlock the extra locks that we got earlier
2182 for (1..$new_locks) {
2183 unfilelock($param{locks});
2186 __end_control(%info);
2189 sub __allow_relocking{
2190 my ($locks,$bugs) = @_;
2192 for my $bug (@{$bugs}) {
2193 my @lockfiles = grep {m{/\Q$bug\E$}} keys %{$locks->{locks}};
2194 next unless @lockfiles;
2195 $locks->{relockable}{$lockfiles[0]} = 0;
2199 sub __disallow_relocking{
2201 delete $locks->{relockable};
2204 sub __lock_and_load_merged_bugs{
2206 validate_with(params => \@_,
2208 {bugs_to_load => {type => ARRAYREF,
2209 default => sub {[]},
2211 data => {type => HASHREF|ARRAYREF,
2213 locks => {type => HASHREF,
2214 default => sub {{};},
2216 reload_all => {type => BOOLEAN,
2219 debug => {type => HANDLE,
2225 if (ref($param{data}) eq 'ARRAY') {
2226 for my $data (@{$param{data}}) {
2227 $data{$data->{bug_num}} = dclone($data);
2231 %data = %{dclone($param{data})};
2233 my @bugs_to_load = @{$param{bugs_to_load}};
2234 if ($param{reload_all}) {
2235 push @bugs_to_load, keys %data;
2238 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2239 @bugs_to_load = keys %temp;
2240 my %loaded_this_time;
2242 while ($bug_to_load = shift @bugs_to_load) {
2243 if (not $param{reload_all}) {
2244 next if exists $data{$bug_to_load};
2247 next if $loaded_this_time{$bug_to_load};
2250 if ($param{reload_all}) {
2251 if (exists $data{$bug_to_load}) {
2256 read_bug(bug => $bug_to_load,
2258 locks => $param{locks},
2260 die "Unable to load bug $bug_to_load";
2261 print {$param{debug}} "read bug $bug_to_load\n";
2262 $data{$data->{bug_num}} = $data;
2263 $new_locks += $lock_bug;
2264 $loaded_this_time{$data->{bug_num}} = 1;
2266 grep {not exists $data{$_}}
2267 split / /,$data->{mergedwith};
2269 return (\%data,$new_locks);
2273 sub __calculate_merge_status{
2274 my ($data_a,$data_h,$master_bug,$merge) = @_;
2277 my $bugs_to_merge = 0;
2278 for my $data (@{$data_a}) {
2279 # check to see if this bug is unmerged in the set
2280 if (not length $data->{mergedwith} or
2281 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2282 $merged_bugs{$data->{bug_num}} = 1;
2285 # the master_bug is the bug that every other bug is made to
2286 # look like. However, if merge is set, tags, fixed and found
2288 if ($data->{bug_num} == $master_bug) {
2289 for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2290 $merge_status{$_} = $data->{$_}
2294 next unless $data->{bug_num} == $master_bug;
2296 $merge_status{tag} = {} if not exists $merge_status{tag};
2297 for my $tag (split /\s+/, $data->{keywords}) {
2298 $merge_status{tag}{$tag} = 1;
2300 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2301 for (qw(fixed found)) {
2302 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2305 return (\%merge_status,$bugs_to_merge);
2310 sub __calculate_merge_changes{
2311 my ($datas,$merge_status,$param) = @_;
2313 my @disallowed_changes;
2314 for my $data (@{$datas}) {
2315 # things that can be forced
2317 # * func is the function to set the new value
2319 # * key is the key of the function to set the value,
2321 # * modify_value is a function which is called to modify the new
2322 # value so that the function will accept it
2324 # * options is an ARRAYREF of options to pass to the function
2326 # * allowed is a BOOLEAN which controls whether this setting
2327 # is allowed to be different by default.
2328 my %force_functions =
2329 (forwarded => {func => \&set_forwarded,
2333 severity => {func => \&set_severity,
2337 blocks => {func => \&set_blocks,
2338 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2342 blockedby => {func => \&set_blocks,
2343 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2347 done => {func => \&set_done,
2351 owner => {func => \&owner,
2355 summary => {func => \&summary,
2359 affects => {func => \&affects,
2363 package => {func => \&set_package,
2367 keywords => {func => \&set_tag,
2369 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2372 fixed_versions => {func => \&set_fixed,
2376 found_versions => {func => \&set_found,
2381 for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2382 # if the ideal bug already has the field set properly, we
2384 if ($field eq 'keywords'){
2385 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2386 join(' ',sort keys %{$merge_status->{tag}});
2388 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2389 next if join(' ', sort @{$data->{$field}}) eq
2390 join(' ',sort keys %{$merge_status->{$field}});
2392 elsif ($merge_status->{$field} eq $data->{$field}) {
2397 bug => $data->{bug_num},
2398 orig_value => $data->{$field},
2400 (exists $force_functions{$field}{modify_value} ?
2401 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2402 $merge_status->{$field}),
2403 value => $merge_status->{$field},
2404 function => $force_functions{$field}{func},
2405 key => $force_functions{$field}{key},
2406 options => $force_functions{$field}{options},
2407 allowed => exists $force_functions{$field}{allowed} ? 0 : $force_functions{$field}{allowed},
2409 if ($param->{force}) {
2410 if ($field ne 'package') {
2411 push @{$changes{$data->{bug_num}}},$change;
2414 if ($param->{allow_reassign}) {
2415 if ($param->{reassign_different_sources}) {
2416 push @{$changes{$data->{bug_num}}},$change;
2419 # allow reassigning if binary_to_source returns at
2420 # least one of the same source packages
2421 my @merge_status_source =
2422 binary_to_source(package => $merge_status->{package},
2425 my @other_bug_source =
2426 binary_to_source(package => $data->{package},
2429 my %merge_status_sources;
2430 @merge_status_sources{@merge_status_source} =
2431 (1) x @merge_status_source;
2432 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2433 push @{$changes{$data->{bug_num}}},$change;
2438 push @disallowed_changes,$change;
2440 # blocks and blocked by are weird; we have to go through and
2441 # set blocks to the other half of the merged bugs
2443 return (\@disallowed_changes,\%changes);
2449 affects(bug => $ref,
2450 transcript => $transcript,
2451 ($dl > 0 ? (debug => $transcript):()),
2452 requester => $header{from},
2453 request_addr => $controlrequestaddr,
2455 affected_packages => \%affected_packages,
2456 recipients => \%recipients,
2464 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2467 This marks a bug as affecting packages which the bug is not actually
2468 in. This should only be used in cases where fixing the bug instantly
2469 resolves the problem in the other packages.
2471 By default, the packages are set to the list of packages passed.
2472 However, if you pass add => 1 or remove => 1, the list of packages
2473 passed are added or removed from the affects list, respectively.
2478 my %param = validate_with(params => \@_,
2479 spec => {bug => {type => SCALAR,
2482 # specific options here
2483 package => {type => SCALAR|ARRAYREF|UNDEF,
2486 add => {type => BOOLEAN,
2489 remove => {type => BOOLEAN,
2493 %append_action_options,
2496 if ($param{add} and $param{remove}) {
2497 croak "Asking to both add and remove affects is nonsensical";
2499 if (not defined $param{package}) {
2500 $param{package} = [];
2503 __begin_control(%param,
2504 command => 'affects'
2506 my ($debug,$transcript) =
2507 @info{qw(debug transcript)};
2508 my @data = @{$info{data}};
2509 my @bugs = @{$info{bugs}};
2511 for my $data (@data) {
2513 print {$debug} "Going to change affects\n";
2514 my @packages = splitpackages($data->{affects});
2516 @packages{@packages} = (1) x @packages;
2519 for my $package (make_list($param{package})) {
2520 next unless defined $package and length $package;
2521 if (not $packages{$package}) {
2522 $packages{$package} = 1;
2523 push @added,$package;
2527 $action = "Added indication that $data->{bug_num} affects ".
2528 english_join(\@added);
2531 elsif ($param{remove}) {
2533 for my $package (make_list($param{package})) {
2534 if ($packages{$package}) {
2535 next unless defined $package and length $package;
2536 delete $packages{$package};
2537 push @removed,$package;
2540 $action = "Removed indication that $data->{bug_num} affects " .
2541 english_join(\@removed);
2544 my %added_packages = ();
2545 my %removed_packages = %packages;
2547 for my $package (make_list($param{package})) {
2548 next unless defined $package and length $package;
2549 $packages{$package} = 1;
2550 delete $removed_packages{$package};
2551 $added_packages{$package} = 1;
2553 if (keys %removed_packages) {
2554 $action = "Removed indication that $data->{bug_num} affects ".
2555 english_join([keys %removed_packages]);
2556 $action .= "\n" if keys %added_packages;
2558 if (keys %added_packages) {
2559 $action .= "Added indication that $data->{bug_num} affects " .
2560 english_join([keys %added_packages]);
2563 if (not length $action) {
2564 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
2565 unless __internal_request();
2568 my $old_data = dclone($data);
2569 $data->{affects} = join(',',keys %packages);
2570 append_action_to_log(bug => $data->{bug_num},
2572 command => 'affects',
2574 old_data => $old_data,
2575 __return_append_to_log_options(
2580 if not exists $param{append_log} or $param{append_log};
2581 writebug($data->{bug_num},$data);
2582 print {$transcript} "$action\n";
2584 __end_control(%info);
2588 =head1 SUMMARY FUNCTIONS
2593 summary(bug => $ref,
2594 transcript => $transcript,
2595 ($dl > 0 ? (debug => $transcript):()),
2596 requester => $header{from},
2597 request_addr => $controlrequestaddr,
2599 affected_packages => \%affected_packages,
2600 recipients => \%recipients,
2606 print {$transcript} "Failed to mark $ref with summary foo: $@";
2609 Handles all setting of summary fields
2611 If summary is undef, unsets the summary
2613 If summary is 0, sets the summary to the first paragraph contained in
2616 If summary is a positive integer, sets the summary to the message specified.
2618 Otherwise, sets summary to the value passed.
2624 my %param = validate_with(params => \@_,
2625 spec => {bug => {type => SCALAR,
2628 # specific options here
2629 summary => {type => SCALAR|UNDEF,
2633 %append_action_options,
2636 # croak "summary must be numeric or undef" if
2637 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2639 __begin_control(%param,
2640 command => 'summary'
2642 my ($debug,$transcript) =
2643 @info{qw(debug transcript)};
2644 my @data = @{$info{data}};
2645 my @bugs = @{$info{bugs}};
2646 # figure out the log that we're going to use
2648 my $summary_msg = '';
2650 if (not defined $param{summary}) {
2652 print {$debug} "Removing summary fields\n";
2653 $action = 'Removed summary';
2655 elsif ($param{summary} =~ /^\d+$/) {
2657 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2658 if ($param{summary} == 0) {
2659 $log = $param{message};
2660 $summary_msg = @records + 1;
2663 if (($param{summary} - 1 ) > $#records) {
2664 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2666 my $record = $records[($param{summary} - 1 )];
2667 if ($record->{type} !~ /incoming-recv|recips/) {
2668 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2670 $summary_msg = $param{summary};
2671 $log = [$record->{text}];
2673 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2674 my $body = $p_o->{body};
2675 my $in_pseudoheaders = 0;
2677 # walk through body until we get non-blank lines
2678 for my $line (@{$body}) {
2679 if ($line =~ /^\s*$/) {
2680 if (length $paragraph) {
2681 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2687 $in_pseudoheaders = 0;
2690 # skip a paragraph if it looks like it's control or
2692 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2693 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2694 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2695 debug|(?:not|)forwarded|priority|
2696 (?:un|)block|limit|(?:un|)archive|
2697 reassign|retitle|affects|wrongpackage
2698 (?:un|force|)merge|user(?:category|tags?|)
2700 if (not length $paragraph) {
2701 print {$debug} "Found control/pseudo-headers and skiping them\n";
2702 $in_pseudoheaders = 1;
2706 next if $in_pseudoheaders;
2707 $paragraph .= $line ." \n";
2709 print {$debug} "Summary is going to be '$paragraph'\n";
2710 $summary = $paragraph;
2711 $summary =~ s/[\n\r]/ /g;
2712 if (not length $summary) {
2713 die "Unable to find summary message to use";
2715 # trim off a trailing spaces
2716 $summary =~ s/\ *$//;
2719 $summary = $param{summary};
2721 for my $data (@data) {
2722 print {$debug} "Going to change summary\n";
2723 if (((not defined $summary or not length $summary) and
2724 (not defined $data->{summary} or not length $data->{summary})) or
2725 $summary eq $data->{summary}) {
2726 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
2727 unless __internal_request();
2730 if (length $summary) {
2731 if (length $data->{summary}) {
2732 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2735 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2738 my $old_data = dclone($data);
2739 $data->{summary} = $summary;
2740 append_action_to_log(bug => $data->{bug_num},
2741 command => 'summary',
2742 old_data => $old_data,
2745 __return_append_to_log_options(
2750 if not exists $param{append_log} or $param{append_log};
2751 writebug($data->{bug_num},$data);
2752 print {$transcript} "$action\n";
2754 __end_control(%info);
2762 =head1 OWNER FUNCTIONS
2768 transcript => $transcript,
2769 ($dl > 0 ? (debug => $transcript):()),
2770 requester => $header{from},
2771 request_addr => $controlrequestaddr,
2773 recipients => \%recipients,
2779 print {$transcript} "Failed to mark $ref as having an owner: $@";
2782 Handles all setting of the owner field; given an owner of undef or of
2783 no length, indicates that a bug is not owned by anyone.
2788 my %param = validate_with(params => \@_,
2789 spec => {bug => {type => SCALAR,
2792 owner => {type => SCALAR|UNDEF,
2795 %append_action_options,
2799 __begin_control(%param,
2802 my ($debug,$transcript) =
2803 @info{qw(debug transcript)};
2804 my @data = @{$info{data}};
2805 my @bugs = @{$info{bugs}};
2807 for my $data (@data) {
2808 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2809 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2810 if (not defined $param{owner} or not length $param{owner}) {
2811 if (not defined $data->{owner} or not length $data->{owner}) {
2812 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2813 unless __internal_request();
2817 $action = "Removed annotation that $config{bug} was owned by " .
2821 if ($data->{owner} eq $param{owner}) {
2822 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2825 if (length $data->{owner}) {
2826 $action = "Owner changed from $data->{owner} to $param{owner}.";
2829 $action = "Owner recorded as $param{owner}."
2832 my $old_data = dclone($data);
2833 $data->{owner} = $param{owner};
2834 append_action_to_log(bug => $data->{bug_num},
2837 old_data => $old_data,
2839 __return_append_to_log_options(
2844 if not exists $param{append_log} or $param{append_log};
2845 writebug($data->{bug_num},$data);
2846 print {$transcript} "$action\n";
2848 __end_control(%info);
2852 =head1 ARCHIVE FUNCTIONS
2859 bug_archive(bug => $bug_num,
2861 transcript => \$transcript,
2866 transcript("Unable to archive $bug_num\n");
2869 transcript($transcript);
2872 This routine archives a bug
2876 =item bug -- bug number
2878 =item check_archiveable -- check wether a bug is archiveable before
2879 archiving; defaults to 1
2881 =item archive_unarchived -- whether to archive bugs which have not
2882 previously been archived; defaults to 1. [Set to 0 when used from
2885 =item ignore_time -- whether to ignore time constraints when archiving
2886 a bug; defaults to 0.
2893 my %param = validate_with(params => \@_,
2894 spec => {bug => {type => SCALAR,
2897 check_archiveable => {type => BOOLEAN,
2900 archive_unarchived => {type => BOOLEAN,
2903 ignore_time => {type => BOOLEAN,
2907 %append_action_options,
2910 my %info = __begin_control(%param,
2911 command => 'archive',
2913 my ($debug,$transcript) = @info{qw(debug transcript)};
2914 my @data = @{$info{data}};
2915 my @bugs = @{$info{bugs}};
2916 my $action = "$config{bug} archived.";
2917 if ($param{check_archiveable} and
2918 not bug_archiveable(bug=>$param{bug},
2919 ignore_time => $param{ignore_time},
2921 print {$transcript} "Bug $param{bug} cannot be archived\n";
2922 die "Bug $param{bug} cannot be archived";
2924 print {$debug} "$param{bug} considering\n";
2925 if (not $param{archive_unarchived} and
2926 not exists $data[0]{unarchived}
2928 print {$transcript} "$param{bug} has not been archived previously\n";
2929 die "$param{bug} has not been archived previously";
2931 add_recipients(recipients => $param{recipients},
2934 transcript => $transcript,
2936 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2937 for my $bug (@bugs) {
2938 if ($param{check_archiveable}) {
2939 die "Bug $bug cannot be archived (but $param{bug} can?)"
2940 unless bug_archiveable(bug=>$bug,
2941 ignore_time => $param{ignore_time},
2945 # If we get here, we can archive/remove this bug
2946 print {$debug} "$param{bug} removing\n";
2947 for my $bug (@bugs) {
2948 #print "$param{bug} removing $bug\n" if $debug;
2949 my $dir = get_hashname($bug);
2950 # First indicate that this bug is being archived
2951 append_action_to_log(bug => $bug,
2953 command => 'archive',
2954 # we didn't actually change the data
2955 # when we archived, so we don't pass
2956 # a real new_data or old_data
2959 __return_append_to_log_options(
2964 if not exists $param{append_log} or $param{append_log};
2965 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2966 if ($config{save_old_bugs}) {
2967 mkpath("$config{spool_dir}/archive/$dir");
2968 foreach my $file (@files_to_remove) {
2969 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2970 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2971 # we need to bail out here if things have
2972 # gone horribly wrong to avoid removing a
2974 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2977 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2979 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2980 print {$transcript} "deleted $bug (from $param{bug})\n";
2982 bughook_archive(@bugs);
2983 __end_control(%info);
2986 =head2 bug_unarchive
2990 bug_unarchive(bug => $bug_num,
2992 transcript => \$transcript,
2997 transcript("Unable to archive bug: $bug_num");
2999 transcript($transcript);
3001 This routine unarchives a bug
3006 my %param = validate_with(params => \@_,
3007 spec => {bug => {type => SCALAR,
3011 %append_action_options,
3015 my %info = __begin_control(%param,
3017 command=>'unarchive');
3018 my ($debug,$transcript) =
3019 @info{qw(debug transcript)};
3020 my @data = @{$info{data}};
3021 my @bugs = @{$info{bugs}};
3022 my $action = "$config{bug} unarchived.";
3023 my @files_to_remove;
3024 for my $bug (@bugs) {
3025 print {$debug} "$param{bug} removing $bug\n";
3026 my $dir = get_hashname($bug);
3027 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3028 mkpath("archive/$dir");
3029 foreach my $file (@files_to_copy) {
3030 # die'ing here sucks
3031 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3032 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3033 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3035 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3036 print {$transcript} "Unarchived $config{bug} $bug\n";
3038 unlink(@files_to_remove) or die "Unable to unlink bugs";
3039 # Indicate that this bug has been archived previously
3040 for my $bug (@bugs) {
3041 my $newdata = readbug($bug);
3042 my $old_data = dclone($newdata);
3043 if (not defined $newdata) {
3044 print {$transcript} "$config{bug} $bug disappeared!\n";
3045 die "Bug $bug disappeared!";
3047 $newdata->{unarchived} = time;
3048 append_action_to_log(bug => $bug,
3050 command => 'unarchive',
3051 new_data => $newdata,
3052 old_data => $old_data,
3053 __return_append_to_log_options(
3058 if not exists $param{append_log} or $param{append_log};
3059 writebug($bug,$newdata);
3061 __end_control(%info);
3064 =head2 append_action_to_log
3066 append_action_to_log
3068 This should probably be moved to Debbugs::Log; have to think that out
3073 sub append_action_to_log{
3074 my %param = validate_with(params => \@_,
3075 spec => {bug => {type => SCALAR,
3078 new_data => {type => HASHREF,
3081 old_data => {type => HASHREF,
3084 command => {type => SCALAR,
3087 action => {type => SCALAR,
3089 requester => {type => SCALAR,
3092 request_addr => {type => SCALAR,
3095 location => {type => SCALAR,
3098 message => {type => SCALAR|ARRAYREF,
3101 recips => {type => SCALAR|ARRAYREF,
3104 desc => {type => SCALAR,
3107 get_lock => {type => BOOLEAN,
3110 locks => {type => HASHREF,
3114 # append_action_options here
3115 # because some of these
3116 # options aren't actually
3117 # optional, even though the
3118 # original function doesn't
3122 # Fix this to use $param{location}
3123 my $log_location = buglog($param{bug});
3124 die "Unable to find .log for $param{bug}"
3125 if not defined $log_location;
3126 if ($param{get_lock}) {
3127 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3131 my $logfh = IO::File->new(">>$log_location") or
3132 die "Unable to open $log_location for appending: $!";
3133 # determine difference between old and new
3135 if (exists $param{old_data} and exists $param{new_data}) {
3136 my $old_data = dclone($param{old_data});
3137 my $new_data = dclone($param{new_data});
3138 for my $key (keys %{$old_data}) {
3139 if (not exists $Debbugs::Status::fields{$key}) {
3140 delete $old_data->{$key};
3143 next unless exists $new_data->{$key};
3144 next unless defined $new_data->{$key};
3145 if (not defined $old_data->{$key}) {
3146 delete $old_data->{$key};
3149 if (ref($new_data->{$key}) and
3150 ref($old_data->{$key}) and
3151 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3152 local $Storable::canonical = 1;
3153 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3154 delete $new_data->{$key};
3155 delete $old_data->{$key};
3158 elsif ($new_data->{$key} eq $old_data->{$key}) {
3159 delete $new_data->{$key};
3160 delete $old_data->{$key};
3163 for my $key (keys %{$new_data}) {
3164 if (not exists $Debbugs::Status::fields{$key}) {
3165 delete $new_data->{$key};
3168 next unless exists $old_data->{$key};
3169 next unless defined $old_data->{$key};
3170 if (not defined $new_data->{$key} or
3171 not exists $Debbugs::Status::fields{$key}) {
3172 delete $new_data->{$key};
3175 if (ref($new_data->{$key}) and
3176 ref($old_data->{$key}) and
3177 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3178 local $Storable::canonical = 1;
3179 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3180 delete $new_data->{$key};
3181 delete $old_data->{$key};
3184 elsif ($new_data->{$key} eq $old_data->{$key}) {
3185 delete $new_data->{$key};
3186 delete $old_data->{$key};
3189 $data_diff .= "<!-- new_data:\n";
3191 for my $key (keys %{$new_data}) {
3192 if (not exists $Debbugs::Status::fields{$key}) {
3193 warn "No such field $key";
3196 $nd{$key} = $new_data->{$key};
3197 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3199 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3200 $data_diff .= "-->\n";
3201 $data_diff .= "<!-- old_data:\n";
3203 for my $key (keys %{$old_data}) {
3204 if (not exists $Debbugs::Status::fields{$key}) {
3205 warn "No such field $key";
3208 $od{$key} = $old_data->{$key};
3209 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3211 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3212 $data_diff .= "-->\n";
3215 (exists $param{command} ?
3216 "<!-- command:".html_escape($param{command})." -->\n":""
3218 (length $param{requester} ?
3219 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3221 (length $param{request_addr} ?
3222 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3224 "<!-- time:".time()." -->\n",
3226 "<strong>".html_escape($param{action})."</strong>\n");
3227 if (length $param{requester}) {
3228 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3230 if (length $param{request_addr}) {
3231 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3233 if (length $param{desc}) {
3234 $msg .= ":<br>\n$param{desc}\n";
3239 push @records, {type => 'html',
3243 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3244 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3245 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3246 text => join('',make_list($param{message})),
3249 write_log_records(logfh=>$logfh,
3250 records => \@records,
3252 close $logfh or die "Unable to close $log_location: $!";
3253 if ($param{get_lock}) {
3254 unfilelock(exists $param{locks}?$param{locks}:());
3262 =head1 PRIVATE FUNCTIONS
3264 =head2 __handle_affected_packages
3266 __handle_affected_packages(affected_packages => {},
3274 sub __handle_affected_packages{
3275 my %param = validate_with(params => \@_,
3276 spec => {%common_options,
3277 data => {type => ARRAYREF|HASHREF
3282 for my $data (make_list($param{data})) {
3283 next unless exists $data->{package} and defined $data->{package};
3284 my @packages = split /\s*,\s*/,$data->{package};
3285 @{$param{affected_packages}}{@packages} = (1) x @packages;
3289 =head2 __handle_debug_transcript
3291 my ($debug,$transcript) = __handle_debug_transcript(%param);
3293 Returns a debug and transcript filehandle
3298 sub __handle_debug_transcript{
3299 my %param = validate_with(params => \@_,
3300 spec => {%common_options},
3303 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3304 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3305 return ($debug,$transcript);
3312 Produces a small bit of bug information to kick out to the transcript
3319 next unless defined $data and exists $data->{bug_num};
3320 $return .= "Bug #".($data->{bug_num}||'').
3321 ((defined $data->{done} and length $data->{done})?
3322 " {Done: $data->{done}}":''
3324 " [".($data->{package}||'(no package)'). "] ".
3325 ($data->{subject}||'(no subject)')."\n";
3331 =head2 __internal_request
3333 __internal_request()
3334 __internal_request($level)
3336 Returns true if the caller of the function calling __internal_request
3337 belongs to __PACKAGE__
3339 This allows us to be magical, and don't bother to print bug info if
3340 the second caller is from this package, amongst other things.
3342 An optional level is allowed, which increments the number of levels to
3343 check by the given value. [This is basically for use by internal
3344 functions like __begin_control which are always called by
3349 sub __internal_request{
3351 $l = 0 if not defined $l;
3352 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3358 sub __return_append_to_log_options{
3360 my $action = $param{action} if exists $param{action};
3361 if (not exists $param{requester}) {
3362 $param{requester} = $config{control_internal_requester};
3364 if (not exists $param{request_addr}) {
3365 $param{request_addr} = $config{control_internal_request_addr};
3367 if (not exists $param{message}) {
3368 my $date = rfc822_date();
3369 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3370 variables => {request_addr => $param{request_addr},
3371 requester => $param{requester},
3377 if (not defined $action) {
3378 carp "Undefined action!";
3379 $action = "unknown action";
3381 return (action => $action,
3382 hash_slice(%param,keys %append_action_options),
3386 =head2 __begin_control
3388 my %info = __begin_control(%param,
3390 command=>'unarchive');
3391 my ($debug,$transcript) = @info{qw(debug transcript)};
3392 my @data = @{$info{data}};
3393 my @bugs = @{$info{bugs}};
3396 Starts the process of modifying a bug; handles all of the generic
3397 things that almost every control request needs
3399 Returns a hash containing
3403 =item new_locks -- number of new locks taken out by this call
3405 =item debug -- the debug file handle
3407 =item transcript -- the transcript file handle
3409 =item data -- an arrayref containing the data of the bugs
3410 corresponding to this request
3412 =item bugs -- an arrayref containing the bug numbers of the bugs
3413 corresponding to this request
3421 sub __begin_control {
3422 my %param = validate_with(params => \@_,
3423 spec => {bug => {type => SCALAR,
3426 archived => {type => BOOLEAN,
3429 command => {type => SCALAR,
3437 my ($debug,$transcript) = __handle_debug_transcript(@_);
3438 print {$debug} "$param{bug} considering\n";
3439 $lockhash = $param{locks} if exists $param{locks};
3441 my $old_die = $SIG{__DIE__};
3442 $SIG{__DIE__} = *sig_die{CODE};
3444 ($new_locks, @data) =
3445 lock_read_all_merged_bugs(bug => $param{bug},
3446 $param{archived}?(location => 'archive'):(),
3447 exists $param{locks} ? (locks => $param{locks}):(),
3449 $locks += $new_locks;
3451 die "Unable to read any bugs successfully.";
3453 if (not $param{archived}) {
3454 for my $data (@data) {
3455 if ($data->{archived}) {
3456 die "Not altering archived bugs; see unarchive.";
3460 if (not __check_limit(data => \@data,
3461 exists $param{limit}?(limit => $param{limit}):(),
3462 transcript => $transcript,
3464 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3467 __handle_affected_packages(%param,data => \@data);
3468 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3469 print {$debug} "$param{bug} read $locks locks\n";
3470 if (not @data or not defined $data[0]) {
3471 print {$transcript} "No bug found for $param{bug}\n";
3472 die "No bug found for $param{bug}";
3475 add_recipients(data => \@data,
3476 recipients => $param{recipients},
3477 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3479 (__internal_request()?(transcript => $transcript):()),
3482 print {$debug} "$param{bug} read done\n";
3483 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3484 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3485 return (data => \@data,
3487 old_die => $old_die,
3488 new_locks => $new_locks,
3490 transcript => $transcript,
3492 exists $param{locks}?(locks => $param{locks}):(),
3496 =head2 __end_control
3498 __end_control(%info);
3500 Handles tearing down from a control request
3506 if (exists $info{new_locks} and $info{new_locks} > 0) {
3507 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3508 for (1..$info{new_locks}) {
3509 unfilelock(exists $info{locks}?$info{locks}:());
3513 $SIG{__DIE__} = $info{old_die};
3514 if (exists $info{param}{affected_bugs}) {
3515 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3517 add_recipients(recipients => $info{param}{recipients},
3518 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3519 data => $info{data},
3520 debug => $info{debug},
3521 transcript => $info{transcript},
3523 __handle_affected_packages(%{$info{param}},data=>$info{data});
3527 =head2 __check_limit
3529 __check_limit(data => \@data, limit => $param{limit});
3532 Checks to make sure that bugs match any limits; each entry of @data
3533 much satisfy the limit.
3535 Returns true if there are no entries in data, or there are no keys in
3536 limit; returns false (0) if there are any entries which do not match.
3538 The limit hashref elements can contain an arrayref of scalars to
3539 match; regexes are also acccepted. At least one of the entries in each
3540 element needs to match the corresponding field in all data for the
3547 my %param = validate_with(params => \@_,
3548 spec => {data => {type => ARRAYREF|SCALAR,
3550 limit => {type => HASHREF|UNDEF,
3552 transcript => {type => SCALARREF|HANDLE,
3557 my @data = make_list($param{data});
3559 not defined $param{limit} or
3560 not keys %{$param{limit}}) {
3563 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3564 my $going_to_fail = 0;
3565 for my $data (@data) {
3566 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3567 status => dclone($data),
3569 for my $field (keys %{$param{limit}}) {
3570 next unless exists $param{limit}{$field};
3572 my @data_fields = make_list($data->{$field});
3573 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3574 if (not ref $limit) {
3575 for my $data_field (@data_fields) {
3576 if ($data_field eq $limit) {
3582 elsif (ref($limit) eq 'Regexp') {
3583 for my $data_field (@data_fields) {
3584 if ($data_field =~ $limit) {
3591 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3596 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3597 "' does not match at least one of ".
3598 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3602 return $going_to_fail?0:1;
3610 We override die to specially handle unlocking files in the cases where
3611 we are called via eval. [If we're not called via eval, it doesn't
3617 if ($^S) { # in eval
3619 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3626 # =head2 __message_body_template
3628 # message_body_template('mail/ack',{ref=>'foo'});
3630 # Creates a message body using a template
3634 sub __message_body_template{
3635 my ($template,$extra_var) = @_;
3637 my $hole_var = {'&bugurl' =>
3639 'http://'.$config{cgi_domain}.'/'.
3640 Debbugs::CGI::bug_url($_[0]);
3644 my $body = fill_in_template(template => $template,
3645 variables => {config => \%config,
3648 hole_var => $hole_var,
3650 return fill_in_template(template => 'mail/message_body',
3651 variables => {config => \%config,
3655 hole_var => $hole_var,
3659 sub __all_undef_or_equal {
3661 return 1 if @values == 1 or @values == 0;
3662 my $not_def = grep {not defined $_} @values;
3663 if ($not_def == @values) {
3666 if ($not_def > 0 and $not_def != @values) {
3669 my $first_val = shift @values;
3670 for my $val (@values) {
3671 if ($first_val ne $val) {