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 __end_control(%info);
901 if (exists $param{submitter}) {
902 set_submitter(bug => $param{bug},
903 submitter => $param{submitter},
905 keys %common_options,
906 keys %append_action_options)
909 # clear the fixed revisions
910 if ($param{clear_fixed}) {
911 set_fixed(fixed => [],
915 keys %common_options,
916 keys %append_action_options),
921 my %submitter_notified;
922 my $requester_notified = 0;
923 my $orig_report_set = 0;
924 for my $data (@data) {
925 my $old_data = dclone($data);
926 my $hash = get_hashname($data->{bug_num});
927 my $report_fh = IO::File->new("db-h/$hash/$data->{bug_num}.report",'r') or
928 die "Unable to open original report db-h/$hash/$data->{bug_num}.report for reading: $!";
932 $orig_report= <$report_fh>;
935 if (not $orig_report_set and defined $orig_report and
936 length $orig_report and
937 exists $param{original_report}){
938 ${$param{original_report}} = $orig_report;
939 $orig_report_set = 1;
942 if (exists $data->{done} and
943 defined $data->{done} and
944 length $data->{done}) {
945 print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
946 __end_control(%info);
949 $action = "Marked $config{bug} as done";
951 # set done to the requester
952 $data->{done} = exists $param{done}?$param{done}:$param{requester};
953 append_action_to_log(bug => $data->{bug_num},
956 old_data => $old_data,
958 __return_append_to_log_options(
963 if not exists $param{append_log} or $param{append_log};
964 writebug($data->{bug_num},$data);
965 # get the original report
966 if ($param{notify_submitter}) {
967 my $submitter_message;
968 if(not exists $submitter_notified{$data->{originator}}) {
970 create_mime_message([default_headers(queue_file => $param{request_nn},
972 msgid => $param{request_msgid},
973 msgtype => 'notifdone',
974 pr_msg => 'they-closed',
976 [To => $data->{submitter},
977 Subject => "$config{ubug}#$data->{bug_num} ".
978 "closed by $param{requester} ($param{request_subject})",
982 __message_body_template('mail/process_your_bug_done',
984 replyto => (exists $param{request_replyto} ?
985 $param{request_replyto} :
986 $param{requester} || 'Unknown'),
987 markedby => $param{requester},
988 subject => $param{request_subject},
989 messageid => $param{request_msgid},
992 [join('',make_list($param{message})),$orig_report]
994 send_mail_message(message => $submitter_message,
995 recipients => $old_data->{submitter},
997 $submitter_notified{$data->{originator}} = $submitter_message;
1000 $submitter_message = $submitter_notified{$data->{originator}};
1002 append_action_to_log(bug => $data->{bug_num},
1003 action => "Notification sent",
1005 request_addr => $data->{originator},
1006 desc => "$config{bug} acknowledged by developer.",
1007 recips => [$data->{originator}],
1008 message => $submitter_message,
1013 if (exists $param{fixed}) {
1014 set_fixed(fixed => $param{fixed},
1018 keys %common_options,
1019 keys %append_action_options
1027 =head2 set_submitter
1030 set_submitter(bug => $ref,
1031 transcript => $transcript,
1032 ($dl > 0 ? (debug => $transcript):()),
1033 requester => $header{from},
1034 request_addr => $controlrequestaddr,
1036 affected_packages => \%affected_packages,
1037 recipients => \%recipients,
1038 submitter => $new_submitter,
1039 notify_submitter => 1,
1044 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1047 Sets the submitter of a bug. If notify_submitter is true (the
1048 default), notifies the old submitter of a bug on changes
1053 my %param = validate_with(params => \@_,
1054 spec => {bug => {type => SCALAR,
1057 # specific options here
1058 submitter => {type => SCALAR,
1060 notify_submitter => {type => BOOLEAN,
1064 %append_action_options,
1067 if (not Mail::RFC822::Address::valid($param{submitter})) {
1068 die "New submitter address $param{submitter} is not a valid e-mail address";
1071 __begin_control(%param,
1072 command => 'submitter'
1074 my ($debug,$transcript) =
1075 @info{qw(debug transcript)};
1076 my @data = @{$info{data}};
1077 my @bugs = @{$info{bugs}};
1079 # here we only concern ourselves with the first of the merged bugs
1080 for my $data ($data[0]) {
1081 my $notify_old_submitter = 0;
1082 my $old_data = dclone($data);
1083 print {$debug} "Going to change bug submitter\n";
1084 if (((not defined $param{submitter} or not length $param{submitter}) and
1085 (not defined $data->{originator} or not length $data->{originator})) or
1086 (defined $param{submitter} and defined $data->{originator} and
1087 $param{submitter} eq $data->{originator})) {
1088 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
1089 unless __internal_request();
1093 if (defined $data->{originator} and length($data->{originator})) {
1094 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
1095 $notify_old_submitter = 1;
1098 $action= "Set $config{bug} submitter to '$param{submitter}'.";
1100 $data->{originator} = $param{submitter};
1102 append_action_to_log(bug => $data->{bug_num},
1103 command => 'submitter',
1105 old_data => $old_data,
1107 __return_append_to_log_options(
1112 if not exists $param{append_log} or $param{append_log};
1113 writebug($data->{bug_num},$data);
1114 print {$transcript} "$action\n";
1115 # notify old submitter
1116 if ($notify_old_submitter and $param{notify_submitter}) {
1117 send_mail_message(message =>
1118 create_mime_message([default_headers(queue_file => $param{request_nn},
1120 msgid => $param{request_msgid},
1122 pr_msg => 'submitter-changed',
1124 [To => $old_data->{submitter},
1125 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
1129 __message_body_template('mail/submitter_changed',
1130 {old_data => $old_data,
1132 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
1136 recipients => $old_data->{submitter},
1140 __end_control(%info);
1145 =head2 set_forwarded
1148 set_forwarded(bug => $ref,
1149 transcript => $transcript,
1150 ($dl > 0 ? (debug => $transcript):()),
1151 requester => $header{from},
1152 request_addr => $controlrequestaddr,
1154 affected_packages => \%affected_packages,
1155 recipients => \%recipients,
1156 forwarded => $forward_to,
1161 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1164 Sets the location to which a bug is forwarded. Given an undef
1165 forwarded, unsets forwarded.
1171 my %param = validate_with(params => \@_,
1172 spec => {bug => {type => SCALAR,
1175 # specific options here
1176 forwarded => {type => SCALAR|UNDEF,
1179 %append_action_options,
1182 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1183 die "Non-printable characters are not allowed in the forwarded field";
1185 $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
1187 __begin_control(%param,
1188 command => 'forwarded'
1190 my ($debug,$transcript) =
1191 @info{qw(debug transcript)};
1192 my @data = @{$info{data}};
1193 my @bugs = @{$info{bugs}};
1195 for my $data (@data) {
1196 my $old_data = dclone($data);
1197 print {$debug} "Going to change bug forwarded\n";
1198 if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
1199 (not defined $param{forwarded} and
1200 defined $data->{forwarded} and not length $data->{forwarded})) {
1201 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1202 unless __internal_request();
1206 if (not defined $param{forwarded}) {
1207 $action= "Unset $config{bug} forwarded-to-address";
1209 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1210 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1213 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1215 $data->{forwarded} = $param{forwarded};
1217 append_action_to_log(bug => $data->{bug_num},
1218 command => 'forwarded',
1220 old_data => $old_data,
1222 __return_append_to_log_options(
1227 if not exists $param{append_log} or $param{append_log};
1228 writebug($data->{bug_num},$data);
1229 print {$transcript} "$action\n";
1231 __end_control(%info);
1240 set_title(bug => $ref,
1241 transcript => $transcript,
1242 ($dl > 0 ? (debug => $transcript):()),
1243 requester => $header{from},
1244 request_addr => $controlrequestaddr,
1246 affected_packages => \%affected_packages,
1247 recipients => \%recipients,
1248 title => $new_title,
1253 print {$transcript} "Failed to set the title of $ref: $@";
1256 Sets the title of a specific bug
1262 my %param = validate_with(params => \@_,
1263 spec => {bug => {type => SCALAR,
1266 # specific options here
1267 title => {type => SCALAR,
1270 %append_action_options,
1273 if ($param{title} =~ /[^[:print:]]/) {
1274 die "Non-printable characters are not allowed in bug titles";
1277 my %info = __begin_control(%param,
1280 my ($debug,$transcript) =
1281 @info{qw(debug transcript)};
1282 my @data = @{$info{data}};
1283 my @bugs = @{$info{bugs}};
1285 for my $data (@data) {
1286 my $old_data = dclone($data);
1287 print {$debug} "Going to change bug title\n";
1288 if (defined $data->{subject} and length($data->{subject}) and
1289 $data->{subject} eq $param{title}) {
1290 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1291 unless __internal_request();
1295 if (defined $data->{subject} and length($data->{subject})) {
1296 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1298 $action= "Set $config{bug} title to '$param{title}'.";
1300 $data->{subject} = $param{title};
1302 append_action_to_log(bug => $data->{bug_num},
1305 old_data => $old_data,
1307 __return_append_to_log_options(
1312 if not exists $param{append_log} or $param{append_log};
1313 writebug($data->{bug_num},$data);
1314 print {$transcript} "$action\n";
1316 __end_control(%info);
1323 set_package(bug => $ref,
1324 transcript => $transcript,
1325 ($dl > 0 ? (debug => $transcript):()),
1326 requester => $header{from},
1327 request_addr => $controlrequestaddr,
1329 affected_packages => \%affected_packages,
1330 recipients => \%recipients,
1331 package => $new_package,
1337 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1340 Indicates that a bug is in a particular package. If is_source is true,
1341 indicates that the package is a source package. [Internally, this
1342 causes src: to be prepended to the package name.]
1344 The default for is_source is 0. As a special case, if the package
1345 starts with 'src:', it is assumed to be a source package and is_source
1348 The package option must match the package_name_re regex.
1353 my %param = validate_with(params => \@_,
1354 spec => {bug => {type => SCALAR,
1357 # specific options here
1358 package => {type => SCALAR|ARRAYREF,
1360 is_source => {type => BOOLEAN,
1364 %append_action_options,
1367 my @new_packages = map {splitpackages($_)} make_list($param{package});
1368 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1369 croak "Invalid package name '".
1370 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1373 my %info = __begin_control(%param,
1374 command => 'package',
1376 my ($debug,$transcript) =
1377 @info{qw(debug transcript)};
1378 my @data = @{$info{data}};
1379 my @bugs = @{$info{bugs}};
1380 # clean up the new package
1384 ($temp =~ s/^src:// or
1385 $param{is_source}) ? 'src:'.$temp:$temp;
1389 my $package_reassigned = 0;
1390 for my $data (@data) {
1391 my $old_data = dclone($data);
1392 print {$debug} "Going to change assigned package\n";
1393 if (defined $data->{package} and length($data->{package}) and
1394 $data->{package} eq $new_package) {
1395 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1396 unless __internal_request();
1400 if (defined $data->{package} and length($data->{package})) {
1401 $package_reassigned = 1;
1402 $action= "$config{bug} reassigned from package '$data->{package}'".
1403 " to '$new_package'.";
1405 $action= "$config{bug} assigned to package '$new_package'.";
1407 $data->{package} = $new_package;
1409 append_action_to_log(bug => $data->{bug_num},
1410 command => 'package',
1412 old_data => $old_data,
1414 __return_append_to_log_options(
1419 if not exists $param{append_log} or $param{append_log};
1420 writebug($data->{bug_num},$data);
1421 print {$transcript} "$action\n";
1423 __end_control(%info);
1424 # Only clear the fixed/found versions if the package has been
1426 if ($package_reassigned) {
1427 my @params_for_found_fixed =
1428 map {exists $param{$_}?($_,$param{$_}):()}
1430 keys %common_options,
1431 keys %append_action_options,
1433 set_found(found => [],
1434 @params_for_found_fixed,
1436 set_fixed(fixed => [],
1437 @params_for_found_fixed,
1445 set_found(bug => $ref,
1446 transcript => $transcript,
1447 ($dl > 0 ? (debug => $transcript):()),
1448 requester => $header{from},
1449 request_addr => $controlrequestaddr,
1451 affected_packages => \%affected_packages,
1452 recipients => \%recipients,
1459 print {$transcript} "Failed to set found on $ref: $@";
1463 Sets, adds, or removes the specified found versions of a package
1465 If the version list is empty, and the bug is currently not "done",
1466 causes the done field to be cleared.
1468 If any of the versions added to found are greater than any version in
1469 which the bug is fixed (or when the bug is found and there are no
1470 fixed versions) the done field is cleared.
1475 my %param = validate_with(params => \@_,
1476 spec => {bug => {type => SCALAR,
1479 # specific options here
1480 found => {type => SCALAR|ARRAYREF,
1483 add => {type => BOOLEAN,
1486 remove => {type => BOOLEAN,
1490 %append_action_options,
1493 if ($param{add} and $param{remove}) {
1494 croak "It's nonsensical to add and remove the same versions";
1498 __begin_control(%param,
1501 my ($debug,$transcript) =
1502 @info{qw(debug transcript)};
1503 my @data = @{$info{data}};
1504 my @bugs = @{$info{bugs}};
1506 for my $version (make_list($param{found})) {
1507 next unless defined $version;
1508 $versions{$version} =
1509 [make_source_versions(package => [splitpackages($data[0]{package})],
1510 warnings => $transcript,
1513 versions => $version,
1516 # This is really ugly, but it's what we have to do
1517 if (not @{$versions{$version}}) {
1518 print {$transcript} "Unable to make a source version for version '$version'\n";
1521 if (not keys %versions and ($param{remove} or $param{add})) {
1522 if ($param{remove}) {
1523 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1526 print {$transcript} "Requested to add no versions; doing nothing.\n";
1528 __end_control(%info);
1531 # first things first, make the versions fully qualified source
1533 for my $data (@data) {
1534 # The 'done' field gets a bit weird with version tracking,
1535 # because a bug may be closed by multiple people in different
1536 # branches. Until we have something more flexible, we set it
1537 # every time a bug is fixed, and clear it when a bug is found
1538 # in a version greater than any version in which the bug is
1539 # fixed or when a bug is found and there is no fixed version
1540 my $action = 'Did not alter found versions';
1541 my %found_added = ();
1542 my %found_removed = ();
1543 my %fixed_removed = ();
1545 my $old_data = dclone($data);
1546 if (not $param{add} and not $param{remove}) {
1547 $found_removed{$_} = 1 for @{$data->{found_versions}};
1548 $data->{found_versions} = [];
1551 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1553 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1554 for my $version (keys %versions) {
1556 my @svers = @{$versions{$version}};
1560 for my $sver (@svers) {
1561 if (not exists $found_versions{$sver}) {
1562 $found_versions{$sver} = 1;
1563 $found_added{$sver} = 1;
1565 # if the found we are adding matches any fixed
1566 # versions, remove them
1567 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1568 delete $fixed_versions{$_} for @temp;
1569 $fixed_removed{$_} = 1 for @temp;
1572 # We only care about reopening the bug if the bug is
1574 if (defined $data->{done} and length $data->{done}) {
1575 my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
1577 # determine if we need to reopen
1578 my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
1579 keys %fixed_versions);
1580 if (not @fixed_order or
1581 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1587 elsif ($param{remove}) {
1588 # in the case of removal, we only concern ourself with
1589 # the version passed, not the source version it maps
1591 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1592 delete $found_versions{$_} for @temp;
1593 $found_removed{$_} = 1 for @temp;
1596 # set the keys to exactly these values
1597 my @svers = @{$versions{$version}};
1601 for my $sver (@svers) {
1602 if (not exists $found_versions{$sver}) {
1603 $found_versions{$sver} = 1;
1604 if (exists $found_removed{$sver}) {
1605 delete $found_removed{$sver};
1608 $found_added{$sver} = 1;
1615 $data->{found_versions} = [keys %found_versions];
1616 $data->{fixed_versions} = [keys %fixed_versions];
1619 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1620 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1621 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1622 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1623 $action = ucfirst(join ('; ',@changed)) if @changed;
1625 $action .= " and reopened"
1627 if (not $reopened and not @changed) {
1628 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1629 unless __internal_request();
1633 append_action_to_log(bug => $data->{bug_num},
1636 old_data => $old_data,
1638 __return_append_to_log_options(
1643 if not exists $param{append_log} or $param{append_log};
1644 writebug($data->{bug_num},$data);
1645 print {$transcript} "$action\n";
1647 __end_control(%info);
1653 set_fixed(bug => $ref,
1654 transcript => $transcript,
1655 ($dl > 0 ? (debug => $transcript):()),
1656 requester => $header{from},
1657 request_addr => $controlrequestaddr,
1659 affected_packages => \%affected_packages,
1660 recipients => \%recipients,
1668 print {$transcript} "Failed to set fixed on $ref: $@";
1672 Sets, adds, or removes the specified fixed versions of a package
1674 If the fixed versions are empty (or end up being empty after this
1675 call) or the greatest fixed version is less than the greatest found
1676 version and the reopen option is true, the bug is reopened.
1678 This function is also called by the reopen function, which causes all
1679 of the fixed versions to be cleared.
1684 my %param = validate_with(params => \@_,
1685 spec => {bug => {type => SCALAR,
1688 # specific options here
1689 fixed => {type => SCALAR|ARRAYREF,
1692 add => {type => BOOLEAN,
1695 remove => {type => BOOLEAN,
1698 reopen => {type => BOOLEAN,
1702 %append_action_options,
1705 if ($param{add} and $param{remove}) {
1706 croak "It's nonsensical to add and remove the same versions";
1709 __begin_control(%param,
1712 my ($debug,$transcript) =
1713 @info{qw(debug transcript)};
1714 my @data = @{$info{data}};
1715 my @bugs = @{$info{bugs}};
1717 for my $version (make_list($param{fixed})) {
1718 next unless defined $version;
1719 $versions{$version} =
1720 [make_source_versions(package => [splitpackages($data[0]{package})],
1721 warnings => $transcript,
1724 versions => $version,
1727 # This is really ugly, but it's what we have to do
1728 if (not @{$versions{$version}}) {
1729 print {$transcript} "Unable to make a source version for version '$version'\n";
1732 if (not keys %versions and ($param{remove} or $param{add})) {
1733 if ($param{remove}) {
1734 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1737 print {$transcript} "Requested to add no versions; doing nothing.\n";
1739 __end_control(%info);
1742 # first things first, make the versions fully qualified source
1744 for my $data (@data) {
1745 my $old_data = dclone($data);
1746 # The 'done' field gets a bit weird with version tracking,
1747 # because a bug may be closed by multiple people in different
1748 # branches. Until we have something more flexible, we set it
1749 # every time a bug is fixed, and clear it when a bug is found
1750 # in a version greater than any version in which the bug is
1751 # fixed or when a bug is found and there is no fixed version
1752 my $action = 'Did not alter fixed versions';
1753 my %found_added = ();
1754 my %found_removed = ();
1755 my %fixed_added = ();
1756 my %fixed_removed = ();
1758 if (not $param{add} and not $param{remove}) {
1759 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1760 $data->{fixed_versions} = [];
1763 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1765 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1766 for my $version (keys %versions) {
1768 my @svers = @{$versions{$version}};
1772 for my $sver (@svers) {
1773 if (not exists $fixed_versions{$sver}) {
1774 $fixed_versions{$sver} = 1;
1775 $fixed_added{$sver} = 1;
1779 elsif ($param{remove}) {
1780 # in the case of removal, we only concern ourself with
1781 # the version passed, not the source version it maps
1783 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1784 delete $fixed_versions{$_} for @temp;
1785 $fixed_removed{$_} = 1 for @temp;
1788 # set the keys to exactly these values
1789 my @svers = @{$versions{$version}};
1793 for my $sver (@svers) {
1794 if (not exists $fixed_versions{$sver}) {
1795 $fixed_versions{$sver} = 1;
1796 if (exists $fixed_removed{$sver}) {
1797 delete $fixed_removed{$sver};
1800 $fixed_added{$sver} = 1;
1807 $data->{found_versions} = [keys %found_versions];
1808 $data->{fixed_versions} = [keys %fixed_versions];
1810 # If we're supposed to consider reopening, reopen if the
1811 # fixed versions are empty or the greatest found version
1812 # is greater than the greatest fixed version
1813 if ($param{reopen} and defined $data->{done}
1814 and length $data->{done}) {
1815 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1816 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1817 # determine if we need to reopen
1818 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1819 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1820 if (not @fixed_order or
1821 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1828 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1829 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1830 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1831 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1832 $action = ucfirst(join ('; ',@changed)) if @changed;
1834 $action .= " and reopened"
1836 if (not $reopened and not @changed) {
1837 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1838 unless __internal_request();
1842 append_action_to_log(bug => $data->{bug_num},
1845 old_data => $old_data,
1847 __return_append_to_log_options(
1852 if not exists $param{append_log} or $param{append_log};
1853 writebug($data->{bug_num},$data);
1854 print {$transcript} "$action\n";
1856 __end_control(%info);
1863 set_merged(bug => $ref,
1864 transcript => $transcript,
1865 ($dl > 0 ? (debug => $transcript):()),
1866 requester => $header{from},
1867 request_addr => $controlrequestaddr,
1869 affected_packages => \%affected_packages,
1870 recipients => \%recipients,
1871 merge_with => 12345,
1874 allow_reassign => 1,
1875 reassign_same_source_only => 1,
1880 print {$transcript} "Failed to set merged on $ref: $@";
1884 Sets, adds, or removes the specified merged bugs of a bug
1886 By default, requires
1891 my %param = validate_with(params => \@_,
1892 spec => {bug => {type => SCALAR,
1895 # specific options here
1896 merge_with => {type => ARRAYREF|SCALAR,
1899 remove => {type => BOOLEAN,
1902 force => {type => BOOLEAN,
1905 masterbug => {type => BOOLEAN,
1908 allow_reassign => {type => BOOLEAN,
1911 reassign_different_sources => {type => BOOLEAN,
1915 %append_action_options,
1918 my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1920 @merging{@merging} = (1) x @merging;
1921 if (grep {$_ !~ /^\d+$/} @merging) {
1922 croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1924 $param{locks} = {} if not exists $param{locks};
1926 __begin_control(%param,
1929 my ($debug,$transcript) =
1930 @info{qw(debug transcript)};
1931 if (not @merging and exists $param{merge_with}) {
1932 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1933 __end_control(%info);
1936 my @data = @{$info{data}};
1937 my @bugs = @{$info{bugs}};
1940 for my $data (@data) {
1941 $data{$data->{bug_num}} = $data;
1942 my @merged_bugs = split / /, $data->{mergedwith};
1943 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1947 if (not exists $param{merge_with}) {
1948 my $ok_to_unmerge = 1;
1949 delete $merged_bugs{$param{bug}};
1950 if (not keys %merged_bugs) {
1951 print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1952 __end_control(%info);
1955 my $action = "Disconnected #$param{bug} from all other report(s).";
1956 for my $data (@data) {
1957 my $old_data = dclone($data);
1958 if ($data->{bug_num} == $param{bug}) {
1959 $data->{mergedwith} = '';
1962 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
1965 append_action_to_log(bug => $data->{bug_num},
1968 old_data => $old_data,
1970 __return_append_to_log_options(%param,
1974 if not exists $param{append_log} or $param{append_log};
1975 writebug($data->{bug_num},$data);
1977 print {$transcript} "$action\n";
1978 __end_control(%info);
1981 # lock and load all of the bugs we need
1982 my @bugs_to_load = keys %merging;
1985 my ($data,$n_locks) =
1986 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
1988 locks => $param{locks},
1991 $new_locks += $n_locks;
1993 @data = values %data;
1994 if (not __check_limit(data => [@data],
1995 exists $param{limit}?(limit => $param{limit}):(),
1996 transcript => $transcript,
1998 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2000 for my $data (@data) {
2001 $data{$data->{bug_num}} = $data;
2002 $merged_bugs{$data->{bug_num}} = 1;
2003 my @merged_bugs = split / /, $data->{mergedwith};
2004 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2005 if (exists $param{affected_bugs}) {
2006 $param{affected_bugs}{$data->{bug_num}} = 1;
2009 __handle_affected_packages(%param,data => [@data]);
2010 my %bug_info_shown; # which bugs have had information shown
2011 $bug_info_shown{$param{bug}} = 1;
2012 add_recipients(data => [@data],
2013 recipients => $param{recipients},
2014 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2016 (__internal_request()?(transcript => $transcript):()),
2019 # Figure out what the ideal state is for the bug,
2020 my ($merge_status,$bugs_to_merge) =
2021 __calculate_merge_status(\@data,\%data,$param{bug});
2022 # find out if we actually have any bugs to merge
2023 if (not $bugs_to_merge) {
2024 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2025 for (1..$new_locks) {
2026 unfilelock($param{locks});
2029 __end_control(%info);
2032 # see what changes need to be made to merge the bugs
2033 # check to make sure that the set of changes we need to make is allowed
2034 my ($disallowed_changes,$changes) =
2035 __calculate_merge_changes(\@data,$merge_status,\%param);
2036 # at this point, stop if there are disallowed changes, otherwise
2037 # make the allowed changes, and then reread the bugs in question
2038 # to get the new data, then recaculate the merges; repeat
2039 # reloading and recalculating until we try too many times or there
2040 # are no changes to make.
2043 # we will allow at most 4 times through this; more than 1
2044 # shouldn't really happen.
2046 while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2047 if ($attempts > 1) {
2048 print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2050 if (@{$disallowed_changes}) {
2051 # figure out the problems
2052 print {$transcript} "Unable to merge bugs because:\n";
2053 for my $change (@{$disallowed_changes}) {
2054 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{orig_value}' not '$change->{value}'\n";
2056 if ($attempts > 0) {
2057 croak "Some bugs were altered while attempting to merge";
2060 croak "Did not alter merged bugs";
2063 my ($change_bug) = keys %{$changes};
2064 $bug_changed{$change_bug}++;
2065 print {$transcript} __bug_info($data{$change_bug}) if
2066 $param{show_bug_info} and not __internal_request(1);
2067 $bug_info_shown{$change_bug} = 1;
2068 __allow_relocking($param{locks},[keys %data]);
2069 for my $change (@{$changes->{$change_bug}}) {
2070 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2071 my %target_blockedby;
2072 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2073 my %unhandled_targets = %target_blockedby;
2074 my @blocks_to_remove;
2075 for my $key (split / /,$change->{orig_value}) {
2076 delete $unhandled_targets{$key};
2077 next if exists $target_blockedby{$key};
2078 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2079 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2082 keys %common_options,
2083 keys %append_action_options),
2086 for my $key (keys %unhandled_targets) {
2087 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2088 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2091 keys %common_options,
2092 keys %append_action_options),
2097 $change->{function}->(bug => $change->{bug},
2098 $change->{key}, $change->{func_value},
2099 exists $change->{options}?@{$change->{options}}:(),
2101 keys %common_options,
2102 keys %append_action_options),
2106 __disallow_relocking($param{locks});
2107 my ($data,$n_locks) =
2108 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2110 locks => $param{locks},
2114 $new_locks += $n_locks;
2117 @data = values %data;
2118 ($merge_status,$bugs_to_merge) =
2119 __calculate_merge_status(\@data,\%data,$param{bug});
2120 ($disallowed_changes,$changes) =
2121 __calculate_merge_changes(\@data,$merge_status,\%param);
2122 $attempts = max(values %bug_changed);
2124 if ($param{show_bug_info} and not __internal_request(1)) {
2125 for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2126 next if $bug_info_shown{$data->{bug_num}};
2127 print {$transcript} __bug_info($data);
2130 if (keys %{$changes} or @{$disallowed_changes}) {
2131 print {$transcript} "Unable to modify bugs so that they could be merged\n";
2132 for (1..$new_locks) {
2133 unfilelock($param{locks});
2136 __end_control(%info);
2140 # finally, we can merge the bugs
2141 my $action = "Merged ".join(' ',sort keys %merged_bugs);
2142 for my $data (@data) {
2143 my $old_data = dclone($data);
2144 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2146 append_action_to_log(bug => $data->{bug_num},
2149 old_data => $old_data,
2151 __return_append_to_log_options(%param,
2155 if not exists $param{append_log} or $param{append_log};
2156 writebug($data->{bug_num},$data);
2158 print {$transcript} "$action\n";
2159 # unlock the extra locks that we got earlier
2160 for (1..$new_locks) {
2161 unfilelock($param{locks});
2164 __end_control(%info);
2167 sub __allow_relocking{
2168 my ($locks,$bugs) = @_;
2170 for my $bug (@{$bugs}) {
2171 my @lockfiles = grep {m{/\Q$bug\E$}} keys %{$locks->{locks}};
2172 next unless @lockfiles;
2173 $locks->{relockable}{$lockfiles[0]} = 0;
2177 sub __disallow_relocking{
2179 delete $locks->{relockable};
2182 sub __lock_and_load_merged_bugs{
2184 validate_with(params => \@_,
2186 {bugs_to_load => {type => ARRAYREF,
2187 default => sub {[]},
2189 data => {type => HASHREF|ARRAYREF,
2191 locks => {type => HASHREF,
2192 default => sub {{};},
2194 reload_all => {type => BOOLEAN,
2197 debug => {type => HANDLE,
2203 if (ref($param{data}) eq 'ARRAY') {
2204 for my $data (@{$param{data}}) {
2205 $data{$data->{bug_num}} = dclone($data);
2209 %data = %{dclone($param{data})};
2211 my @bugs_to_load = @{$param{bugs_to_load}};
2212 if ($param{reload_all}) {
2213 push @bugs_to_load, keys %data;
2216 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2217 @bugs_to_load = keys %temp;
2218 my %loaded_this_time;
2220 while ($bug_to_load = shift @bugs_to_load) {
2221 if (not $param{reload_all}) {
2222 next if exists $data{$bug_to_load};
2225 next if $loaded_this_time{$bug_to_load};
2228 if ($param{reload_all}) {
2229 if (exists $data{$bug_to_load}) {
2234 read_bug(bug => $bug_to_load,
2236 locks => $param{locks},
2238 die "Unable to load bug $bug_to_load";
2239 print {$param{debug}} "read bug $bug_to_load\n";
2240 $data{$data->{bug_num}} = $data;
2241 $new_locks += $lock_bug;
2242 $loaded_this_time{$data->{bug_num}} = 1;
2244 grep {not exists $data{$_}}
2245 split / /,$data->{mergedwith};
2247 return (\%data,$new_locks);
2251 sub __calculate_merge_status{
2252 my ($data_a,$data_h,$master_bug,$merge) = @_;
2255 my $bugs_to_merge = 0;
2256 for my $data (@{$data_a}) {
2257 # check to see if this bug is unmerged in the set
2258 if (not length $data->{mergedwith} or
2259 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2260 $merged_bugs{$data->{bug_num}} = 1;
2263 # the master_bug is the bug that every other bug is made to
2264 # look like. However, if merge is set, tags, fixed and found
2266 if ($data->{bug_num} == $master_bug) {
2267 for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2268 $merge_status{$_} = $data->{$_}
2272 next unless $data->{bug_num} == $master_bug;
2274 $merge_status{tag} = {} if not exists $merge_status{tag};
2275 for my $tag (split /\s+/, $data->{keywords}) {
2276 $merge_status{tag}{$tag} = 1;
2278 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2279 for (qw(fixed found)) {
2280 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2283 return (\%merge_status,$bugs_to_merge);
2288 sub __calculate_merge_changes{
2289 my ($datas,$merge_status,$param) = @_;
2291 my @disallowed_changes;
2292 for my $data (@{$datas}) {
2293 # things that can be forced
2295 # * func is the function to set the new value
2297 # * key is the key of the function to set the value,
2299 # * modify_value is a function which is called to modify the new
2300 # value so that the function will accept it
2302 # * options is an ARRAYREF of options to pass to the function
2304 # * allowed is a BOOLEAN which controls whether this setting
2305 # is allowed to be different by default.
2306 my %force_functions =
2307 (forwarded => {func => \&set_forwarded,
2311 severity => {func => \&set_severity,
2315 blocks => {func => \&set_blocks,
2316 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2320 blockedby => {func => \&set_blocks,
2321 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2325 done => {func => \&set_done,
2329 owner => {func => \&owner,
2333 summary => {func => \&summary,
2337 affects => {func => \&affects,
2341 package => {func => \&set_package,
2345 keywords => {func => \&set_tag,
2347 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2350 fixed_versions => {func => \&set_fixed,
2354 found_versions => {func => \&set_found,
2359 for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2360 # if the ideal bug already has the field set properly, we
2362 if ($field eq 'keywords'){
2363 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2364 join(' ',sort keys %{$merge_status->{tag}});
2366 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2367 next if join(' ', sort @{$data->{$field}}) eq
2368 join(' ',sort keys %{$merge_status->{$field}});
2370 elsif ($merge_status->{$field} eq $data->{$field}) {
2375 bug => $data->{bug_num},
2376 orig_value => $data->{$field},
2378 (exists $force_functions{$field}{modify_value} ?
2379 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2380 $merge_status->{$field}),
2381 value => $merge_status->{$field},
2382 function => $force_functions{$field}{func},
2383 key => $force_functions{$field}{key},
2384 options => $force_functions{$field}{options},
2385 allowed => exists $force_functions{$field}{allowed} ? 0 : $force_functions{$field}{allowed},
2387 if ($param->{force}) {
2388 if ($field ne 'package') {
2389 push @{$changes{$data->{bug_num}}},$change;
2392 if ($param->{allow_reassign}) {
2393 if ($param->{reassign_different_sources}) {
2394 push @{$changes{$data->{bug_num}}},$change;
2397 # allow reassigning if binary_to_source returns at
2398 # least one of the same source packages
2399 my @merge_status_source =
2400 binary_to_source(package => $merge_status->{package},
2403 my @other_bug_source =
2404 binary_to_source(package => $data->{package},
2407 my %merge_status_sources;
2408 @merge_status_sources{@merge_status_source} =
2409 (1) x @merge_status_source;
2410 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2411 push @{$changes{$data->{bug_num}}},$change;
2416 push @disallowed_changes,$change;
2418 # blocks and blocked by are weird; we have to go through and
2419 # set blocks to the other half of the merged bugs
2421 return (\@disallowed_changes,\%changes);
2427 affects(bug => $ref,
2428 transcript => $transcript,
2429 ($dl > 0 ? (debug => $transcript):()),
2430 requester => $header{from},
2431 request_addr => $controlrequestaddr,
2433 affected_packages => \%affected_packages,
2434 recipients => \%recipients,
2442 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2445 This marks a bug as affecting packages which the bug is not actually
2446 in. This should only be used in cases where fixing the bug instantly
2447 resolves the problem in the other packages.
2449 By default, the packages are set to the list of packages passed.
2450 However, if you pass add => 1 or remove => 1, the list of packages
2451 passed are added or removed from the affects list, respectively.
2456 my %param = validate_with(params => \@_,
2457 spec => {bug => {type => SCALAR,
2460 # specific options here
2461 package => {type => SCALAR|ARRAYREF|UNDEF,
2464 add => {type => BOOLEAN,
2467 remove => {type => BOOLEAN,
2471 %append_action_options,
2474 if ($param{add} and $param{remove}) {
2475 croak "Asking to both add and remove affects is nonsensical";
2477 if (not defined $param{package}) {
2478 $param{package} = [];
2481 __begin_control(%param,
2482 command => 'affects'
2484 my ($debug,$transcript) =
2485 @info{qw(debug transcript)};
2486 my @data = @{$info{data}};
2487 my @bugs = @{$info{bugs}};
2489 for my $data (@data) {
2491 print {$debug} "Going to change affects\n";
2492 my @packages = splitpackages($data->{affects});
2494 @packages{@packages} = (1) x @packages;
2497 for my $package (make_list($param{package})) {
2498 next unless defined $package and length $package;
2499 if (not $packages{$package}) {
2500 $packages{$package} = 1;
2501 push @added,$package;
2505 $action = "Added indication that $data->{bug_num} affects ".
2506 english_join(\@added);
2509 elsif ($param{remove}) {
2511 for my $package (make_list($param{package})) {
2512 if ($packages{$package}) {
2513 next unless defined $package and length $package;
2514 delete $packages{$package};
2515 push @removed,$package;
2518 $action = "Removed indication that $data->{bug_num} affects " .
2519 english_join(\@removed);
2522 my %added_packages = ();
2523 my %removed_packages = %packages;
2525 for my $package (make_list($param{package})) {
2526 next unless defined $package and length $package;
2527 $packages{$package} = 1;
2528 delete $removed_packages{$package};
2529 $added_packages{$package} = 1;
2531 if (keys %removed_packages) {
2532 $action = "Removed indication that $data->{bug_num} affects ".
2533 english_join([keys %removed_packages]);
2534 $action .= "\n" if keys %added_packages;
2536 if (keys %added_packages) {
2537 $action .= "Added indication that $data->{bug_num} affects " .
2538 english_join([keys %added_packages]);
2541 if (not length $action) {
2542 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
2543 unless __internal_request();
2546 my $old_data = dclone($data);
2547 $data->{affects} = join(',',keys %packages);
2548 append_action_to_log(bug => $data->{bug_num},
2550 command => 'affects',
2552 old_data => $old_data,
2553 __return_append_to_log_options(
2558 if not exists $param{append_log} or $param{append_log};
2559 writebug($data->{bug_num},$data);
2560 print {$transcript} "$action\n";
2562 __end_control(%info);
2566 =head1 SUMMARY FUNCTIONS
2571 summary(bug => $ref,
2572 transcript => $transcript,
2573 ($dl > 0 ? (debug => $transcript):()),
2574 requester => $header{from},
2575 request_addr => $controlrequestaddr,
2577 affected_packages => \%affected_packages,
2578 recipients => \%recipients,
2584 print {$transcript} "Failed to mark $ref with summary foo: $@";
2587 Handles all setting of summary fields
2589 If summary is undef, unsets the summary
2591 If summary is 0, sets the summary to the first paragraph contained in
2594 If summary is a positive integer, sets the summary to the message specified.
2596 Otherwise, sets summary to the value passed.
2602 my %param = validate_with(params => \@_,
2603 spec => {bug => {type => SCALAR,
2606 # specific options here
2607 summary => {type => SCALAR|UNDEF,
2611 %append_action_options,
2614 # croak "summary must be numeric or undef" if
2615 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2617 __begin_control(%param,
2618 command => 'summary'
2620 my ($debug,$transcript) =
2621 @info{qw(debug transcript)};
2622 my @data = @{$info{data}};
2623 my @bugs = @{$info{bugs}};
2624 # figure out the log that we're going to use
2626 my $summary_msg = '';
2628 if (not defined $param{summary}) {
2630 print {$debug} "Removing summary fields\n";
2631 $action = 'Removed summary';
2633 elsif ($param{summary} =~ /^\d+$/) {
2635 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2636 if ($param{summary} == 0) {
2637 $log = $param{message};
2638 $summary_msg = @records + 1;
2641 if (($param{summary} - 1 ) > $#records) {
2642 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2644 my $record = $records[($param{summary} - 1 )];
2645 if ($record->{type} !~ /incoming-recv|recips/) {
2646 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2648 $summary_msg = $param{summary};
2649 $log = [$record->{text}];
2651 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2652 my $body = $p_o->{body};
2653 my $in_pseudoheaders = 0;
2655 # walk through body until we get non-blank lines
2656 for my $line (@{$body}) {
2657 if ($line =~ /^\s*$/) {
2658 if (length $paragraph) {
2659 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2665 $in_pseudoheaders = 0;
2668 # skip a paragraph if it looks like it's control or
2670 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2671 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2672 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2673 debug|(?:not|)forwarded|priority|
2674 (?:un|)block|limit|(?:un|)archive|
2675 reassign|retitle|affects|wrongpackage
2676 (?:un|force|)merge|user(?:category|tags?|)
2678 if (not length $paragraph) {
2679 print {$debug} "Found control/pseudo-headers and skiping them\n";
2680 $in_pseudoheaders = 1;
2684 next if $in_pseudoheaders;
2685 $paragraph .= $line ." \n";
2687 print {$debug} "Summary is going to be '$paragraph'\n";
2688 $summary = $paragraph;
2689 $summary =~ s/[\n\r]/ /g;
2690 if (not length $summary) {
2691 die "Unable to find summary message to use";
2693 # trim off a trailing spaces
2694 $summary =~ s/\ *$//;
2697 $summary = $param{summary};
2699 for my $data (@data) {
2700 print {$debug} "Going to change summary\n";
2701 if (((not defined $summary or not length $summary) and
2702 (not defined $data->{summary} or not length $data->{summary})) or
2703 $summary eq $data->{summary}) {
2704 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
2705 unless __internal_request();
2708 if (length $summary) {
2709 if (length $data->{summary}) {
2710 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2713 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2716 my $old_data = dclone($data);
2717 $data->{summary} = $summary;
2718 append_action_to_log(bug => $data->{bug_num},
2719 command => 'summary',
2720 old_data => $old_data,
2723 __return_append_to_log_options(
2728 if not exists $param{append_log} or $param{append_log};
2729 writebug($data->{bug_num},$data);
2730 print {$transcript} "$action\n";
2732 __end_control(%info);
2740 =head1 OWNER FUNCTIONS
2746 transcript => $transcript,
2747 ($dl > 0 ? (debug => $transcript):()),
2748 requester => $header{from},
2749 request_addr => $controlrequestaddr,
2751 recipients => \%recipients,
2757 print {$transcript} "Failed to mark $ref as having an owner: $@";
2760 Handles all setting of the owner field; given an owner of undef or of
2761 no length, indicates that a bug is not owned by anyone.
2766 my %param = validate_with(params => \@_,
2767 spec => {bug => {type => SCALAR,
2770 owner => {type => SCALAR|UNDEF,
2773 %append_action_options,
2777 __begin_control(%param,
2780 my ($debug,$transcript) =
2781 @info{qw(debug transcript)};
2782 my @data = @{$info{data}};
2783 my @bugs = @{$info{bugs}};
2785 for my $data (@data) {
2786 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2787 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2788 if (not defined $param{owner} or not length $param{owner}) {
2789 if (not defined $data->{owner} or not length $data->{owner}) {
2790 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2791 unless __internal_request();
2795 $action = "Removed annotation that $config{bug} was owned by " .
2799 if ($data->{owner} eq $param{owner}) {
2800 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2803 if (length $data->{owner}) {
2804 $action = "Owner changed from $data->{owner} to $param{owner}.";
2807 $action = "Owner recorded as $param{owner}."
2810 my $old_data = dclone($data);
2811 $data->{owner} = $param{owner};
2812 append_action_to_log(bug => $data->{bug_num},
2815 old_data => $old_data,
2817 __return_append_to_log_options(
2822 if not exists $param{append_log} or $param{append_log};
2823 writebug($data->{bug_num},$data);
2824 print {$transcript} "$action\n";
2826 __end_control(%info);
2830 =head1 ARCHIVE FUNCTIONS
2837 bug_archive(bug => $bug_num,
2839 transcript => \$transcript,
2844 transcript("Unable to archive $bug_num\n");
2847 transcript($transcript);
2850 This routine archives a bug
2854 =item bug -- bug number
2856 =item check_archiveable -- check wether a bug is archiveable before
2857 archiving; defaults to 1
2859 =item archive_unarchived -- whether to archive bugs which have not
2860 previously been archived; defaults to 1. [Set to 0 when used from
2863 =item ignore_time -- whether to ignore time constraints when archiving
2864 a bug; defaults to 0.
2871 my %param = validate_with(params => \@_,
2872 spec => {bug => {type => SCALAR,
2875 check_archiveable => {type => BOOLEAN,
2878 archive_unarchived => {type => BOOLEAN,
2881 ignore_time => {type => BOOLEAN,
2885 %append_action_options,
2888 my %info = __begin_control(%param,
2889 command => 'archive',
2891 my ($debug,$transcript) = @info{qw(debug transcript)};
2892 my @data = @{$info{data}};
2893 my @bugs = @{$info{bugs}};
2894 my $action = "$config{bug} archived.";
2895 if ($param{check_archiveable} and
2896 not bug_archiveable(bug=>$param{bug},
2897 ignore_time => $param{ignore_time},
2899 print {$transcript} "Bug $param{bug} cannot be archived\n";
2900 die "Bug $param{bug} cannot be archived";
2902 print {$debug} "$param{bug} considering\n";
2903 if (not $param{archive_unarchived} and
2904 not exists $data[0]{unarchived}
2906 print {$transcript} "$param{bug} has not been archived previously\n";
2907 die "$param{bug} has not been archived previously";
2909 add_recipients(recipients => $param{recipients},
2912 transcript => $transcript,
2914 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2915 for my $bug (@bugs) {
2916 if ($param{check_archiveable}) {
2917 die "Bug $bug cannot be archived (but $param{bug} can?)"
2918 unless bug_archiveable(bug=>$bug,
2919 ignore_time => $param{ignore_time},
2923 # If we get here, we can archive/remove this bug
2924 print {$debug} "$param{bug} removing\n";
2925 for my $bug (@bugs) {
2926 #print "$param{bug} removing $bug\n" if $debug;
2927 my $dir = get_hashname($bug);
2928 # First indicate that this bug is being archived
2929 append_action_to_log(bug => $bug,
2931 command => 'archive',
2932 # we didn't actually change the data
2933 # when we archived, so we don't pass
2934 # a real new_data or old_data
2937 __return_append_to_log_options(
2942 if not exists $param{append_log} or $param{append_log};
2943 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2944 if ($config{save_old_bugs}) {
2945 mkpath("$config{spool_dir}/archive/$dir");
2946 foreach my $file (@files_to_remove) {
2947 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2948 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2949 # we need to bail out here if things have
2950 # gone horribly wrong to avoid removing a
2952 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2955 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2957 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2958 print {$transcript} "deleted $bug (from $param{bug})\n";
2960 bughook_archive(@bugs);
2961 __end_control(%info);
2964 =head2 bug_unarchive
2968 bug_unarchive(bug => $bug_num,
2970 transcript => \$transcript,
2975 transcript("Unable to archive bug: $bug_num");
2977 transcript($transcript);
2979 This routine unarchives a bug
2984 my %param = validate_with(params => \@_,
2985 spec => {bug => {type => SCALAR,
2989 %append_action_options,
2993 my %info = __begin_control(%param,
2995 command=>'unarchive');
2996 my ($debug,$transcript) =
2997 @info{qw(debug transcript)};
2998 my @data = @{$info{data}};
2999 my @bugs = @{$info{bugs}};
3000 my $action = "$config{bug} unarchived.";
3001 my @files_to_remove;
3002 for my $bug (@bugs) {
3003 print {$debug} "$param{bug} removing $bug\n";
3004 my $dir = get_hashname($bug);
3005 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3006 mkpath("archive/$dir");
3007 foreach my $file (@files_to_copy) {
3008 # die'ing here sucks
3009 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3010 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3011 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3013 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3014 print {$transcript} "Unarchived $config{bug} $bug\n";
3016 unlink(@files_to_remove) or die "Unable to unlink bugs";
3017 # Indicate that this bug has been archived previously
3018 for my $bug (@bugs) {
3019 my $newdata = readbug($bug);
3020 my $old_data = dclone($newdata);
3021 if (not defined $newdata) {
3022 print {$transcript} "$config{bug} $bug disappeared!\n";
3023 die "Bug $bug disappeared!";
3025 $newdata->{unarchived} = time;
3026 append_action_to_log(bug => $bug,
3028 command => 'unarchive',
3029 new_data => $newdata,
3030 old_data => $old_data,
3031 __return_append_to_log_options(
3036 if not exists $param{append_log} or $param{append_log};
3037 writebug($bug,$newdata);
3039 __end_control(%info);
3042 =head2 append_action_to_log
3044 append_action_to_log
3046 This should probably be moved to Debbugs::Log; have to think that out
3051 sub append_action_to_log{
3052 my %param = validate_with(params => \@_,
3053 spec => {bug => {type => SCALAR,
3056 new_data => {type => HASHREF,
3059 old_data => {type => HASHREF,
3062 command => {type => SCALAR,
3065 action => {type => SCALAR,
3067 requester => {type => SCALAR,
3070 request_addr => {type => SCALAR,
3073 location => {type => SCALAR,
3076 message => {type => SCALAR|ARRAYREF,
3079 recips => {type => SCALAR|ARRAYREF,
3082 desc => {type => SCALAR,
3085 get_lock => {type => BOOLEAN,
3088 locks => {type => HASHREF,
3092 # append_action_options here
3093 # because some of these
3094 # options aren't actually
3095 # optional, even though the
3096 # original function doesn't
3100 # Fix this to use $param{location}
3101 my $log_location = buglog($param{bug});
3102 die "Unable to find .log for $param{bug}"
3103 if not defined $log_location;
3104 if ($param{get_lock}) {
3105 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3109 my $logfh = IO::File->new(">>$log_location") or
3110 die "Unable to open $log_location for appending: $!";
3111 # determine difference between old and new
3113 if (exists $param{old_data} and exists $param{new_data}) {
3114 my $old_data = dclone($param{old_data});
3115 my $new_data = dclone($param{new_data});
3116 for my $key (keys %{$old_data}) {
3117 if (not exists $Debbugs::Status::fields{$key}) {
3118 delete $old_data->{$key};
3121 next unless exists $new_data->{$key};
3122 next unless defined $new_data->{$key};
3123 if (not defined $old_data->{$key}) {
3124 delete $old_data->{$key};
3127 if (ref($new_data->{$key}) and
3128 ref($old_data->{$key}) and
3129 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3130 local $Storable::canonical = 1;
3131 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3132 delete $new_data->{$key};
3133 delete $old_data->{$key};
3136 elsif ($new_data->{$key} eq $old_data->{$key}) {
3137 delete $new_data->{$key};
3138 delete $old_data->{$key};
3141 for my $key (keys %{$new_data}) {
3142 if (not exists $Debbugs::Status::fields{$key}) {
3143 delete $new_data->{$key};
3146 next unless exists $old_data->{$key};
3147 next unless defined $old_data->{$key};
3148 if (not defined $new_data->{$key} or
3149 not exists $Debbugs::Status::fields{$key}) {
3150 delete $new_data->{$key};
3153 if (ref($new_data->{$key}) and
3154 ref($old_data->{$key}) and
3155 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3156 local $Storable::canonical = 1;
3157 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3158 delete $new_data->{$key};
3159 delete $old_data->{$key};
3162 elsif ($new_data->{$key} eq $old_data->{$key}) {
3163 delete $new_data->{$key};
3164 delete $old_data->{$key};
3167 $data_diff .= "<!-- new_data:\n";
3169 for my $key (keys %{$new_data}) {
3170 if (not exists $Debbugs::Status::fields{$key}) {
3171 warn "No such field $key";
3174 $nd{$key} = $new_data->{$key};
3175 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3177 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3178 $data_diff .= "-->\n";
3179 $data_diff .= "<!-- old_data:\n";
3181 for my $key (keys %{$old_data}) {
3182 if (not exists $Debbugs::Status::fields{$key}) {
3183 warn "No such field $key";
3186 $od{$key} = $old_data->{$key};
3187 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3189 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3190 $data_diff .= "-->\n";
3193 (exists $param{command} ?
3194 "<!-- command:".html_escape($param{command})." -->\n":""
3196 (length $param{requester} ?
3197 "<!-- requester: ".html_escape($param{requester})." -->\n":""
3199 (length $param{request_addr} ?
3200 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3202 "<!-- time:".time()." -->\n",
3204 "<strong>".html_escape($param{action})."</strong>\n");
3205 if (length $param{requester}) {
3206 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3208 if (length $param{request_addr}) {
3209 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3211 if (length $param{desc}) {
3212 $msg .= ":<br>\n$param{desc}\n";
3217 push @records, {type => 'html',
3221 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3222 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3223 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3224 text => join('',make_list($param{message})),
3227 write_log_records(logfh=>$logfh,
3228 records => \@records,
3230 close $logfh or die "Unable to close $log_location: $!";
3231 if ($param{get_lock}) {
3232 unfilelock(exists $param{locks}?$param{locks}:());
3240 =head1 PRIVATE FUNCTIONS
3242 =head2 __handle_affected_packages
3244 __handle_affected_packages(affected_packages => {},
3252 sub __handle_affected_packages{
3253 my %param = validate_with(params => \@_,
3254 spec => {%common_options,
3255 data => {type => ARRAYREF|HASHREF
3260 for my $data (make_list($param{data})) {
3261 next unless exists $data->{package} and defined $data->{package};
3262 my @packages = split /\s*,\s*/,$data->{package};
3263 @{$param{affected_packages}}{@packages} = (1) x @packages;
3267 =head2 __handle_debug_transcript
3269 my ($debug,$transcript) = __handle_debug_transcript(%param);
3271 Returns a debug and transcript filehandle
3276 sub __handle_debug_transcript{
3277 my %param = validate_with(params => \@_,
3278 spec => {%common_options},
3281 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3282 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3283 return ($debug,$transcript);
3290 Produces a small bit of bug information to kick out to the transcript
3297 next unless defined $data and exists $data->{bug_num};
3298 $return .= "Bug #".($data->{bug_num}||'').
3299 ((defined $data->{done} and length $data->{done})?
3300 " {Done: $data->{done}}":''
3302 " [".($data->{package}||'(no package)'). "] ".
3303 ($data->{subject}||'(no subject)')."\n";
3309 =head2 __internal_request
3311 __internal_request()
3312 __internal_request($level)
3314 Returns true if the caller of the function calling __internal_request
3315 belongs to __PACKAGE__
3317 This allows us to be magical, and don't bother to print bug info if
3318 the second caller is from this package, amongst other things.
3320 An optional level is allowed, which increments the number of levels to
3321 check by the given value. [This is basically for use by internal
3322 functions like __begin_control which are always called by
3327 sub __internal_request{
3329 $l = 0 if not defined $l;
3330 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3336 sub __return_append_to_log_options{
3338 my $action = $param{action} if exists $param{action};
3339 if (not exists $param{requester}) {
3340 $param{requester} = $config{control_internal_requester};
3342 if (not exists $param{request_addr}) {
3343 $param{request_addr} = $config{control_internal_request_addr};
3345 if (not exists $param{message}) {
3346 my $date = rfc822_date();
3347 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3348 variables => {request_addr => $param{request_addr},
3349 requester => $param{requester},
3355 if (not defined $action) {
3356 carp "Undefined action!";
3357 $action = "unknown action";
3359 return (action => $action,
3360 hash_slice(%param,keys %append_action_options),
3364 =head2 __begin_control
3366 my %info = __begin_control(%param,
3368 command=>'unarchive');
3369 my ($debug,$transcript) = @info{qw(debug transcript)};
3370 my @data = @{$info{data}};
3371 my @bugs = @{$info{bugs}};
3374 Starts the process of modifying a bug; handles all of the generic
3375 things that almost every control request needs
3377 Returns a hash containing
3381 =item new_locks -- number of new locks taken out by this call
3383 =item debug -- the debug file handle
3385 =item transcript -- the transcript file handle
3387 =item data -- an arrayref containing the data of the bugs
3388 corresponding to this request
3390 =item bugs -- an arrayref containing the bug numbers of the bugs
3391 corresponding to this request
3399 sub __begin_control {
3400 my %param = validate_with(params => \@_,
3401 spec => {bug => {type => SCALAR,
3404 archived => {type => BOOLEAN,
3407 command => {type => SCALAR,
3415 my ($debug,$transcript) = __handle_debug_transcript(@_);
3416 print {$debug} "$param{bug} considering\n";
3417 $lockhash = $param{locks} if exists $param{locks};
3419 my $old_die = $SIG{__DIE__};
3420 $SIG{__DIE__} = *sig_die{CODE};
3422 ($new_locks, @data) =
3423 lock_read_all_merged_bugs(bug => $param{bug},
3424 $param{archived}?(location => 'archive'):(),
3425 exists $param{locks} ? (locks => $param{locks}):(),
3427 $locks += $new_locks;
3429 die "Unable to read any bugs successfully.";
3431 if (not $param{archived}) {
3432 for my $data (@data) {
3433 if ($data->{archived}) {
3434 die "Not altering archived bugs; see unarchive.";
3438 if (not __check_limit(data => \@data,
3439 exists $param{limit}?(limit => $param{limit}):(),
3440 transcript => $transcript,
3442 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3445 __handle_affected_packages(%param,data => \@data);
3446 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3447 print {$debug} "$param{bug} read $locks locks\n";
3448 if (not @data or not defined $data[0]) {
3449 print {$transcript} "No bug found for $param{bug}\n";
3450 die "No bug found for $param{bug}";
3453 add_recipients(data => \@data,
3454 recipients => $param{recipients},
3455 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3457 (__internal_request()?(transcript => $transcript):()),
3460 print {$debug} "$param{bug} read done\n";
3461 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3462 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3463 return (data => \@data,
3465 old_die => $old_die,
3466 new_locks => $new_locks,
3468 transcript => $transcript,
3470 exists $param{locks}?(locks => $param{locks}):(),
3474 =head2 __end_control
3476 __end_control(%info);
3478 Handles tearing down from a control request
3484 if (exists $info{new_locks} and $info{new_locks} > 0) {
3485 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3486 for (1..$info{new_locks}) {
3487 unfilelock(exists $info{locks}?$info{locks}:());
3491 $SIG{__DIE__} = $info{old_die};
3492 if (exists $info{param}{affected_bugs}) {
3493 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3495 add_recipients(recipients => $info{param}{recipients},
3496 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3497 data => $info{data},
3498 debug => $info{debug},
3499 transcript => $info{transcript},
3501 __handle_affected_packages(%{$info{param}},data=>$info{data});
3505 =head2 __check_limit
3507 __check_limit(data => \@data, limit => $param{limit});
3510 Checks to make sure that bugs match any limits; each entry of @data
3511 much satisfy the limit.
3513 Returns true if there are no entries in data, or there are no keys in
3514 limit; returns false (0) if there are any entries which do not match.
3516 The limit hashref elements can contain an arrayref of scalars to
3517 match; regexes are also acccepted. At least one of the entries in each
3518 element needs to match the corresponding field in all data for the
3525 my %param = validate_with(params => \@_,
3526 spec => {data => {type => ARRAYREF|SCALAR,
3528 limit => {type => HASHREF|UNDEF,
3530 transcript => {type => SCALARREF|HANDLE,
3535 my @data = make_list($param{data});
3537 not defined $param{limit} or
3538 not keys %{$param{limit}}) {
3541 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3542 my $going_to_fail = 0;
3543 for my $data (@data) {
3544 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3545 status => dclone($data),
3547 for my $field (keys %{$param{limit}}) {
3548 next unless exists $param{limit}{$field};
3550 my @data_fields = make_list($data->{$field});
3551 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3552 if (not ref $limit) {
3553 for my $data_field (@data_fields) {
3554 if ($data_field eq $limit) {
3560 elsif (ref($limit) eq 'Regexp') {
3561 for my $data_field (@data_fields) {
3562 if ($data_field =~ $limit) {
3569 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3574 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3575 "' does not match at least one of ".
3576 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3580 return $going_to_fail?0:1;
3588 We override die to specially handle unlocking files in the cases where
3589 we are called via eval. [If we're not called via eval, it doesn't
3595 if ($^S) { # in eval
3597 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3604 # =head2 __message_body_template
3606 # message_body_template('mail/ack',{ref=>'foo'});
3608 # Creates a message body using a template
3612 sub __message_body_template{
3613 my ($template,$extra_var) = @_;
3615 my $hole_var = {'&bugurl' =>
3617 'http://'.$config{cgi_domain}.'/'.
3618 Debbugs::CGI::bug_url($_[0]);
3622 my $body = fill_in_template(template => $template,
3623 variables => {config => \%config,
3626 hole_var => $hole_var,
3628 return fill_in_template(template => 'mail/message_body',
3629 variables => {config => \%config,
3633 hole_var => $hole_var,
3637 sub __all_undef_or_equal {
3639 return 1 if @values == 1 or @values == 0;
3640 my $not_def = grep {not defined $_} @values;
3641 if ($not_def == @values) {
3644 if ($not_def > 0 and $not_def != @values) {
3647 my $first_val = shift @values;
3648 for my $val (@values) {
3649 if ($first_val ne $val) {