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 = (reopen => [qw(reopen)],
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 archive => [qw(bug_archive bug_unarchive),
99 log => [qw(append_action_to_log),
103 Exporter::export_ok_tags(keys %EXPORT_TAGS);
104 $EXPORT_TAGS{all} = [@EXPORT_OK];
107 use Debbugs::Config qw(:config);
108 use Debbugs::Common qw(:lock buglog :misc get_hashname);
109 use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages);
110 use Debbugs::CGI qw(html_escape);
111 use Debbugs::Log qw(:misc);
112 use Debbugs::Recipients qw(:add);
113 use Debbugs::Packages qw(:versions :mapping);
115 use Params::Validate qw(validate_with :types);
116 use File::Path qw(mkpath);
119 use Debbugs::Text qw(:templates);
121 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
122 use Debbugs::MIME qw(create_mime_message);
124 use Mail::RFC822::Address qw();
126 use POSIX qw(strftime);
128 use Storable qw(dclone nfreeze);
129 use List::Util qw(first);
133 # These are a set of options which are common to all of these functions
135 my %common_options = (debug => {type => SCALARREF|HANDLE,
138 transcript => {type => SCALARREF|HANDLE,
141 affected_bugs => {type => HASHREF,
144 affected_packages => {type => HASHREF,
147 recipients => {type => HASHREF,
150 limit => {type => HASHREF,
153 show_bug_info => {type => BOOLEAN,
156 request_subject => {type => SCALAR,
157 default => 'Unknown Subject',
159 request_msgid => {type => SCALAR,
162 request_nn => {type => SCALAR,
165 request_replyto => {type => SCALAR,
171 my %append_action_options =
172 (action => {type => SCALAR,
175 requester => {type => SCALAR,
178 request_addr => {type => SCALAR,
181 location => {type => SCALAR,
184 message => {type => SCALAR|ARRAYREF,
187 append_log => {type => BOOLEAN,
189 depends => [qw(requester request_addr),
196 # this is just a generic stub for Debbugs::Control functions.
201 # set_foo(bug => $ref,
202 # transcript => $transcript,
203 # ($dl > 0 ? (debug => $transcript):()),
204 # requester => $header{from},
205 # request_addr => $controlrequestaddr,
207 # affected_packages => \%affected_packages,
208 # recipients => \%recipients,
214 # print {$transcript} "Failed to set foo $ref bar: $@";
222 # my %param = validate_with(params => \@_,
223 # spec => {bug => {type => SCALAR,
224 # regex => qr/^\d+$/,
226 # # specific options here
228 # %append_action_options,
232 # __begin_control(%param,
235 # my ($debug,$transcript) =
236 # @info{qw(debug transcript)};
237 # my @data = @{$info{data}};
238 # my @bugs = @{$info{bugs}};
241 # for my $data (@data) {
242 # append_action_to_log(bug => $data->{bug_num},
244 # __return_append_to_log_options(
249 # if not exists $param{append_log} or $param{append_log};
250 # writebug($data->{bug_num},$data);
251 # print {$transcript} "$action\n";
253 # __end_control(%info);
260 set_block(bug => $ref,
261 transcript => $transcript,
262 ($dl > 0 ? (debug => $transcript):()),
263 requester => $header{from},
264 request_addr => $controlrequestaddr,
266 affected_packages => \%affected_packages,
267 recipients => \%recipients,
273 print {$transcript} "Failed to set blockers of $ref: $@";
276 Alters the set of bugs that block this bug from being fixed
278 This requires altering both this bug (and those it's merged with) as
279 well as the bugs that block this bug from being fixed (and those that
284 =item block -- scalar or arrayref of blocking bugs to set, add or remove
286 =item add -- if true, add blocking bugs
288 =item remove -- if true, remove blocking bugs
295 my %param = validate_with(params => \@_,
296 spec => {bug => {type => SCALAR,
299 # specific options here
300 block => {type => SCALAR|ARRAYREF,
303 add => {type => BOOLEAN,
306 remove => {type => BOOLEAN,
310 %append_action_options,
313 if ($param{add} and $param{remove}) {
314 croak "It's nonsensical to add and remove the same blocking bugs";
316 if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
317 croak "Invalid blocking bug(s):".
318 join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
321 if (exists $param{add}) {
324 elsif (exists $param{remove}) {
329 __begin_control(%param,
332 my ($debug,$transcript) =
333 @info{qw(debug transcript)};
334 my @data = @{$info{data}};
335 my @bugs = @{$info{bugs}};
338 # The first bit of this code is ugly, and should be cleaned up.
339 # Its purpose is to populate %removed_blockers and %add_blockers
340 # with all of the bugs that should be added or removed as blockers
341 # of all of the bugs which are merged with $param{bug}
344 for my $blocker (make_list($param{block})) {
345 next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
346 my $data = read_bug(bug=>$blocker,
348 if (defined $data and not $data->{archive}) {
349 $ok_blockers{$blocker} = 1;
351 push @merged_bugs, split(' ',$data->{mergedwith}) if length $data->{mergedwith};
352 $ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
355 $bad_blockers{$blocker} = 1;
359 # throw an error if we are setting the blockers and there is a bad
361 if (keys %bad_blockers and $mode eq 'set') {
362 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
363 keys %ok_blockers?'':" and no known blocking bug(s)";
365 # if there are no ok blockers and we are not setting the blockers,
367 if (not keys %ok_blockers and $mode ne 'set') {
368 print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
369 if (keys %bad_blockers) {
370 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
372 __end_control(%info);
376 my @change_blockers = keys %ok_blockers;
378 my %removed_blockers;
381 my @blockers = map {split ' ', $_->{blockedby}} @data;
383 @blockers{@blockers} = (1) x @blockers;
385 # it is nonsensical for a bug to block itself (or a merged
386 # partner); We currently don't allow removal because we'd possibly
390 @bugs{@bugs} = (1) x @bugs;
391 for my $blocker (@change_blockers) {
392 if ($bugs{$blocker}) {
393 croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
396 @blockers = keys %blockers;
398 %removed_blockers = ();
399 for my $blocker (@change_blockers) {
400 next if exists $blockers{$blocker};
401 $blockers{$blocker} = 1;
402 $added_blockers{$blocker} = 1;
405 elsif ($param{remove}) {
406 %added_blockers = ();
407 for my $blocker (@change_blockers) {
408 next if exists $removed_blockers{$blocker};
409 delete $blockers{$blocker};
410 $removed_blockers{$blocker} = 1;
414 @removed_blockers{@blockers} = (1) x @blockers;
416 for my $blocker (@change_blockers) {
417 next if exists $blockers{$blocker};
418 $blockers{$blocker} = 1;
419 if (exists $removed_blockers{$blocker}) {
420 delete $removed_blockers{$blocker};
423 $added_blockers{$blocker} = 1;
427 my @new_blockers = keys %blockers;
428 for my $data (@data) {
429 my $old_data = dclone($data);
430 # remove blockers and/or add new ones as appropriate
431 if ($data->{blockedby} eq '') {
432 print {$transcript} "Was not blocked by any bugs.\n";
434 print {$transcript} "Was blocked by: $data->{blockedby}\n";
437 push @changed, 'added blocking bug(s) '.english_join([keys %added_blockers]) if keys %added_blockers;
438 push @changed, 'removed blocking bug(s) '.english_join([keys %removed_blockers]) if keys %removed_blockers;
439 $action = ucfirst(join ('; ',@changed)) if @changed;
441 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
442 unless __internal_request();
445 $data->{blockedby} = join(' ',keys %blockers);
446 append_action_to_log(bug => $data->{bug_num},
448 old_data => $old_data,
451 __return_append_to_log_options(
456 if not exists $param{append_log} or $param{append_log};
457 writebug($data->{bug_num},$data);
458 print {$transcript} "$action\n";
460 # we do this bit below to avoid code duplication
462 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
463 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
464 for my $add_remove (keys %mungable_blocks) {
468 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
469 next if $munge_blockers{$blocker};
470 my ($new_locks, @blocking_data) =
471 lock_read_all_merged_bugs($blocker,
472 ($param{archived}?'archive':()));
473 if (not @blocking_data) {
474 unfilelock() for $new_locks;
475 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
477 for (map {$_->{bug_num}} @blocking_data) {
478 $munge_blockers{$_} = 1;
480 for my $data (@blocking_data) {
481 my $old_data = dclone($data);
483 %blocks = split ' ', $data->{blocks};
485 for my $bug (@bugs) {
486 if ($add_remove eq 'remove') {
487 next unless exists $blocks{$bug};
488 delete $blocks{$bug};
491 next if exists $blocks{$bug};
496 $data->{blocks} = join(' ',sort keys %blocks);
497 my $action = ($add_remove eq 'add'?'Added':'Removed').
498 " indication that bug $data->{bug_num} blocks".
500 append_action_to_log(bug => $data->{bug_num},
502 old_data => $old_data,
505 __return_append_to_log_options(%param,
510 __handle_affected_packages(%param,data=>\@blocking_data);
511 add_recipients(recipients => $param{recipients},
512 actions_taken => {blocks => 1},
513 data => \@blocking_data,
515 transcript => $transcript,
518 unfilelock() for $new_locks;
521 __end_control(%info);
530 transcript => $transcript,
531 ($dl > 0 ? (debug => $transcript):()),
532 requester => $header{from},
533 request_addr => $controlrequestaddr,
535 affected_packages => \%affected_packages,
536 recipients => \%recipients,
543 print {$transcript} "Failed to set tag on $ref: $@";
547 Sets, adds, or removes the specified tags on a bug
551 =item tag -- scalar or arrayref of tags to set, add or remove
553 =item add -- if true, add tags
555 =item remove -- if true, remove tags
557 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
565 my %param = validate_with(params => \@_,
566 spec => {bug => {type => SCALAR,
569 # specific options here
570 tag => {type => SCALAR|ARRAYREF,
573 add => {type => BOOLEAN,
576 remove => {type => BOOLEAN,
579 warn_on_bad_tags => {type => BOOLEAN,
583 %append_action_options,
586 if ($param{add} and $param{remove}) {
587 croak "It's nonsensical to add and remove the same tags";
591 __begin_control(%param,
594 my ($debug,$transcript) =
595 @info{qw(debug transcript)};
596 my @data = @{$info{data}};
597 my @bugs = @{$info{bugs}};
598 my @tags = make_list($param{tag});
599 if (not @tags and ($param{remove} or $param{add})) {
600 if ($param{remove}) {
601 print {$transcript} "Requested to remove no tags; doing nothing.\n";
604 print {$transcript} "Requested to add no tags; doing nothing.\n";
606 __end_control(%info);
609 # first things first, make the versions fully qualified source
611 for my $data (@data) {
612 my $action = 'Did not alter tags';
614 my %tag_removed = ();
615 my %fixed_removed = ();
616 my @old_tags = split /\,\s*/, $data->{tags};
618 @tags{@old_tags} = (1) x @old_tags;
620 my $old_data = dclone($data);
621 if (not $param{add} and not $param{remove}) {
622 $tag_removed{$_} = 1 for @old_tags;
626 for my $tag (@tags) {
627 if (not $param{remove} and
628 not defined first {$_ eq $tag} @{$config{tags}}) {
629 push @bad_tags, $tag;
633 if (not exists $tags{$tag}) {
635 $tag_added{$tag} = 1;
638 elsif ($param{remove}) {
639 if (exists $tags{$tag}) {
641 $tag_removed{$tag} = 1;
645 if (exists $tag_removed{$tag}) {
646 delete $tag_removed{$tag};
649 $tag_added{$tag} = 1;
654 if (@bad_tags and $param{warn_on_bad_tags}) {
655 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
656 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
658 $data->{tags} = join(', ',keys %tags); # double check this
661 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
662 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
663 $action = ucfirst(join ('; ',@changed)) if @changed;
665 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
666 unless __internal_request();
670 append_action_to_log(bug => $data->{bug_num},
673 old_data => $old_data,
675 __return_append_to_log_options(
680 if not exists $param{append_log} or $param{append_log};
681 writebug($data->{bug_num},$data);
682 print {$transcript} "$action\n";
684 __end_control(%info);
692 set_severity(bug => $ref,
693 transcript => $transcript,
694 ($dl > 0 ? (debug => $transcript):()),
695 requester => $header{from},
696 request_addr => $controlrequestaddr,
698 affected_packages => \%affected_packages,
699 recipients => \%recipients,
700 severity => 'normal',
705 print {$transcript} "Failed to set the severity of bug $ref: $@";
708 Sets the severity of a bug. If severity is not passed, is undefined,
709 or has zero length, sets the severity to the defafult severity.
714 my %param = validate_with(params => \@_,
715 spec => {bug => {type => SCALAR,
718 # specific options here
719 severity => {type => SCALAR|UNDEF,
720 default => $config{default_severity},
723 %append_action_options,
726 if (not defined $param{severity} or
727 not length $param{severity}
729 $param{severity} = $config{default_severity};
732 # check validity of new severity
733 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
734 die "Severity '$param{severity}' is not a valid severity level";
737 __begin_control(%param,
738 command => 'severity'
740 my ($debug,$transcript) =
741 @info{qw(debug transcript)};
742 my @data = @{$info{data}};
743 my @bugs = @{$info{bugs}};
746 for my $data (@data) {
747 if (not defined $data->{severity}) {
748 $data->{severity} = $param{severity};
749 $action = "Severity set to '$param{severity}'\n";
752 if ($data->{severity} eq '') {
753 $data->{severity} = $config{default_severity};
755 if ($data->{severity} eq $param{severity}) {
756 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
759 $action = "Severity set to '$param{severity}' from '$data->{severity}'\n";
760 $data->{severity} = $param{severity};
762 append_action_to_log(bug => $data->{bug_num},
764 __return_append_to_log_options(
769 if not exists $param{append_log} or $param{append_log};
770 writebug($data->{bug_num},$data);
771 print {$transcript} "$action\n";
773 __end_control(%info);
781 transcript => $transcript,
782 ($dl > 0 ? (debug => $transcript):()),
783 requester => $header{from},
784 request_addr => $controlrequestaddr,
786 affected_packages => \%affected_packages,
787 recipients => \%recipients,
793 print {$transcript} "Failed to set foo $ref bar: $@";
801 my %param = validate_with(params => \@_,
802 spec => {bug => {type => SCALAR,
805 # specific options here
806 submitter => {type => SCALAR|UNDEF,
810 %append_action_options,
814 $param{submitter} = undef if defined $param{submitter} and
815 not length $param{submitter};
817 if (defined $param{submitter} and
818 not Mail::RFC822::Address::valid($param{submitter})) {
819 die "New submitter address $param{submitter} is not a valid e-mail address";
823 __begin_control(%param,
826 my ($debug,$transcript) =
827 @info{qw(debug transcript)};
828 my @data = @{$info{data}};
829 my @bugs = @{$info{bugs}};
832 my $warn_fixed = 1; # avoid warning multiple times if there are
834 my @change_submitter = ();
835 my @bugs_to_reopen = ();
836 for my $data (@data) {
837 if (not exists $data->{done} or
838 not defined $data->{done} or
839 not length $data->{done}) {
840 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
841 __end_control(%info);
844 if (@{$data->{fixed_versions}} and $warn_fixed) {
845 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
846 print {$transcript} "you may need to use 'found' to remove fixed versions.\n";
849 if (defined $param{submitter} and length $param{submitter}
850 and $data->{originator} ne $param{submitter}) {
851 push @change_submitter,$data->{bug_num};
854 __end_control(%info);
855 my @params_for_subcalls =
856 map {exists $param{$_}?($_,$param{$_}):()}
857 (keys %common_options,
858 keys %append_action_options,
861 for my $bug (@change_submitter) {
862 set_submitter(bug=>$bug,
863 submitter => $param{submitter},
864 @params_for_subcalls,
867 set_fixed(fixed => [],
877 set_submitter(bug => $ref,
878 transcript => $transcript,
879 ($dl > 0 ? (debug => $transcript):()),
880 requester => $header{from},
881 request_addr => $controlrequestaddr,
883 affected_packages => \%affected_packages,
884 recipients => \%recipients,
885 submitter => $new_submitter,
886 notify_submitter => 1,
891 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
894 Sets the submitter of a bug. If notify_submitter is true (the
895 default), notifies the old submitter of a bug on changes
900 my %param = validate_with(params => \@_,
901 spec => {bug => {type => SCALAR,
904 # specific options here
905 submitter => {type => SCALAR,
907 notify_submitter => {type => BOOLEAN,
911 %append_action_options,
914 if (not Mail::RFC822::Address::valid($param{submitter})) {
915 die "New submitter address $param{submitter} is not a valid e-mail address";
918 __begin_control(%param,
919 command => 'submitter'
921 my ($debug,$transcript) =
922 @info{qw(debug transcript)};
923 my @data = @{$info{data}};
924 my @bugs = @{$info{bugs}};
926 # here we only concern ourselves with the first of the merged bugs
927 for my $data ($data[0]) {
928 my $notify_old_submitter = 0;
929 my $old_data = dclone($data);
930 print {$debug} "Going to change bug submitter\n";
931 if (((not defined $param{submitter} or not length $param{submitter}) and
932 (not defined $data->{originator} or not length $data->{originator})) or
933 (defined $param{submitter} and defined $data->{originator} and
934 $param{submitter} eq $data->{originator})) {
935 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
936 unless __internal_request();
940 if (defined $data->{originator} and length($data->{originator})) {
941 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
942 $notify_old_submitter = 1;
945 $action= "Set $config{bug} submitter to '$param{submitter}'.";
947 $data->{originator} = $param{submitter};
949 append_action_to_log(bug => $data->{bug_num},
950 command => 'submitter',
952 old_data => $old_data,
954 __return_append_to_log_options(
959 if not exists $param{append_log} or $param{append_log};
960 writebug($data->{bug_num},$data);
961 print {$transcript} "$action\n";
962 # notify old submitter
963 if ($notify_old_submitter and $param{notify_submitter}) {
964 send_mail_message(message =>
965 create_mime_message([default_headers(queue_file => $param{request_nn},
967 msgid => $param{request_msgid},
969 pr_msg => 'submitter-changed',
971 [To => $old_data->{submitter},
972 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
976 __message_body_template('mail/submitter_changed',
977 {old_data => $old_data,
979 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
983 recipients => $old_data->{submitter},
987 __end_control(%info);
995 set_forwarded(bug => $ref,
996 transcript => $transcript,
997 ($dl > 0 ? (debug => $transcript):()),
998 requester => $header{from},
999 request_addr => $controlrequestaddr,
1001 affected_packages => \%affected_packages,
1002 recipients => \%recipients,
1003 forwarded => $forward_to,
1008 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1011 Sets the location to which a bug is forwarded. Given an undef
1012 forwarded, unsets forwarded.
1018 my %param = validate_with(params => \@_,
1019 spec => {bug => {type => SCALAR,
1022 # specific options here
1023 forwarded => {type => SCALAR|UNDEF,
1026 %append_action_options,
1029 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1030 die "Non-printable characters are not allowed in the forwarded field";
1033 __begin_control(%param,
1034 command => 'forwarded'
1036 my ($debug,$transcript) =
1037 @info{qw(debug transcript)};
1038 my @data = @{$info{data}};
1039 my @bugs = @{$info{bugs}};
1041 for my $data (@data) {
1042 my $old_data = dclone($data);
1043 print {$debug} "Going to change bug forwarded\n";
1044 if (((not defined $param{forwarded} or not length $param{forwarded}) and
1045 (not defined $data->{forwarded} or not length $data->{forwarded})) or
1046 $param{forwarded} eq $data->{forwarded}) {
1047 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1048 unless __internal_request();
1052 if (not defined $param{forwarded}) {
1053 $action= "Unset $config{bug} forwarded-to-address";
1055 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1056 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1059 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1061 $data->{forwarded} = $param{forwarded};
1063 append_action_to_log(bug => $data->{bug_num},
1064 command => 'forwarded',
1066 old_data => $old_data,
1068 __return_append_to_log_options(
1073 if not exists $param{append_log} or $param{append_log};
1074 writebug($data->{bug_num},$data);
1075 print {$transcript} "$action\n";
1077 __end_control(%info);
1086 set_title(bug => $ref,
1087 transcript => $transcript,
1088 ($dl > 0 ? (debug => $transcript):()),
1089 requester => $header{from},
1090 request_addr => $controlrequestaddr,
1092 affected_packages => \%affected_packages,
1093 recipients => \%recipients,
1094 title => $new_title,
1099 print {$transcript} "Failed to set the title of $ref: $@";
1102 Sets the title of a specific bug
1108 my %param = validate_with(params => \@_,
1109 spec => {bug => {type => SCALAR,
1112 # specific options here
1113 title => {type => SCALAR,
1116 %append_action_options,
1119 if ($param{title} =~ /[^[:print:]]/) {
1120 die "Non-printable characters are not allowed in bug titles";
1123 my %info = __begin_control(%param,
1126 my ($debug,$transcript) =
1127 @info{qw(debug transcript)};
1128 my @data = @{$info{data}};
1129 my @bugs = @{$info{bugs}};
1131 for my $data (@data) {
1132 my $old_data = dclone($data);
1133 print {$debug} "Going to change bug title\n";
1134 if (defined $data->{subject} and length($data->{subject}) and
1135 $data->{subject} eq $param{title}) {
1136 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1137 unless __internal_request();
1141 if (defined $data->{subject} and length($data->{subject})) {
1142 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1144 $action= "Set $config{bug} title to '$param{title}'.";
1146 $data->{subject} = $param{title};
1148 append_action_to_log(bug => $data->{bug_num},
1151 old_data => $old_data,
1153 __return_append_to_log_options(
1158 if not exists $param{append_log} or $param{append_log};
1159 writebug($data->{bug_num},$data);
1160 print {$transcript} "$action\n";
1162 __end_control(%info);
1169 set_package(bug => $ref,
1170 transcript => $transcript,
1171 ($dl > 0 ? (debug => $transcript):()),
1172 requester => $header{from},
1173 request_addr => $controlrequestaddr,
1175 affected_packages => \%affected_packages,
1176 recipients => \%recipients,
1177 package => $new_package,
1183 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1186 Indicates that a bug is in a particular package. If is_source is true,
1187 indicates that the package is a source package. [Internally, this
1188 causes src: to be prepended to the package name.]
1190 The default for is_source is 0. As a special case, if the package
1191 starts with 'src:', it is assumed to be a source package and is_source
1194 The package option must match the package_name_re regex.
1199 my %param = validate_with(params => \@_,
1200 spec => {bug => {type => SCALAR,
1203 # specific options here
1204 package => {type => SCALAR|ARRAYREF,
1206 is_source => {type => BOOLEAN,
1210 %append_action_options,
1213 my @new_packages = map {splitpackages($_)} make_list($param{package});
1214 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1215 croak "Invalid package name '".
1216 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1219 my %info = __begin_control(%param,
1220 command => 'package',
1222 my ($debug,$transcript) =
1223 @info{qw(debug transcript)};
1224 my @data = @{$info{data}};
1225 my @bugs = @{$info{bugs}};
1226 # clean up the new package
1230 ($temp =~ s/^src:// or
1231 $param{is_source}) ? 'src:'.$temp:$temp;
1235 my $package_reassigned = 0;
1236 for my $data (@data) {
1237 my $old_data = dclone($data);
1238 print {$debug} "Going to change assigned package\n";
1239 if (defined $data->{package} and length($data->{package}) and
1240 $data->{package} eq $new_package) {
1241 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1242 unless __internal_request();
1246 if (defined $data->{package} and length($data->{package})) {
1247 $package_reassigned = 1;
1248 $action= "$config{bug} reassigned from package '$data->{package}'".
1249 " to '$new_package'.";
1251 $action= "$config{bug} assigned to package '$new_package'.";
1253 $data->{package} = $new_package;
1255 append_action_to_log(bug => $data->{bug_num},
1256 command => 'package',
1258 old_data => $old_data,
1260 __return_append_to_log_options(
1265 if not exists $param{append_log} or $param{append_log};
1266 writebug($data->{bug_num},$data);
1267 print {$transcript} "$action\n";
1269 __end_control(%info);
1270 # Only clear the fixed/found versions if the package has been
1272 if ($package_reassigned) {
1273 my @params_for_found_fixed =
1274 map {exists $param{$_}?($_,$param{$_}):()}
1276 keys %common_options,
1277 keys %append_action_options,
1279 set_found(found => [],
1280 @params_for_found_fixed,
1282 set_fixed(fixed => [],
1283 @params_for_found_fixed,
1291 set_found(bug => $ref,
1292 transcript => $transcript,
1293 ($dl > 0 ? (debug => $transcript):()),
1294 requester => $header{from},
1295 request_addr => $controlrequestaddr,
1297 affected_packages => \%affected_packages,
1298 recipients => \%recipients,
1305 print {$transcript} "Failed to set found on $ref: $@";
1309 Sets, adds, or removes the specified found versions of a package
1311 If the version list is empty, and the bug is currently not "done",
1312 causes the done field to be cleared.
1314 If any of the versions added to found are greater than any version in
1315 which the bug is fixed (or when the bug is found and there are no
1316 fixed versions) the done field is cleared.
1321 my %param = validate_with(params => \@_,
1322 spec => {bug => {type => SCALAR,
1325 # specific options here
1326 found => {type => SCALAR|ARRAYREF,
1329 add => {type => BOOLEAN,
1332 remove => {type => BOOLEAN,
1336 %append_action_options,
1339 if ($param{add} and $param{remove}) {
1340 croak "It's nonsensical to add and remove the same versions";
1344 __begin_control(%param,
1347 my ($debug,$transcript) =
1348 @info{qw(debug transcript)};
1349 my @data = @{$info{data}};
1350 my @bugs = @{$info{bugs}};
1352 for my $version (make_list($param{found})) {
1353 next unless defined $version;
1354 $versions{$version} =
1355 [make_source_versions(package => [splitpackages($data[0]{package})],
1356 warnings => $transcript,
1359 versions => $version,
1362 # This is really ugly, but it's what we have to do
1363 if (not @{$versions{$version}}) {
1364 print {$transcript} "Unable to make a source version for version '$version'\n";
1367 if (not keys %versions and ($param{remove} or $param{add})) {
1368 if ($param{remove}) {
1369 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1372 print {$transcript} "Requested to add no versions; doing nothing.\n";
1374 __end_control(%info);
1377 # first things first, make the versions fully qualified source
1379 for my $data (@data) {
1380 # The 'done' field gets a bit weird with version tracking,
1381 # because a bug may be closed by multiple people in different
1382 # branches. Until we have something more flexible, we set it
1383 # every time a bug is fixed, and clear it when a bug is found
1384 # in a version greater than any version in which the bug is
1385 # fixed or when a bug is found and there is no fixed version
1386 my $action = 'Did not alter found versions';
1387 my %found_added = ();
1388 my %found_removed = ();
1389 my %fixed_removed = ();
1391 my $old_data = dclone($data);
1392 if (not $param{add} and not $param{remove}) {
1393 $found_removed{$_} = 1 for @{$data->{found_versions}};
1394 $data->{found_versions} = [];
1397 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1399 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1400 for my $version (keys %versions) {
1402 my @svers = @{$versions{$version}};
1406 for my $sver (@svers) {
1407 if (not exists $found_versions{$sver}) {
1408 $found_versions{$sver} = 1;
1409 $found_added{$sver} = 1;
1411 # if the found we are adding matches any fixed
1412 # versions, remove them
1413 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1414 delete $fixed_versions{$_} for @temp;
1415 $fixed_removed{$_} = 1 for @temp;
1418 # We only care about reopening the bug if the bug is
1420 if (defined $data->{done} and length $data->{done}) {
1421 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1422 map {m{([^/]+)$}; $1;} @svers;
1423 # determine if we need to reopen
1424 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1425 map {m{([^/]+)$}; $1;} keys %fixed_versions;
1426 if (not @fixed_order or
1427 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1433 elsif ($param{remove}) {
1434 # in the case of removal, we only concern ourself with
1435 # the version passed, not the source version it maps
1437 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1438 delete $found_versions{$_} for @temp;
1439 $found_removed{$_} = 1 for @temp;
1442 # set the keys to exactly these values
1443 my @svers = @{$versions{$version}};
1447 for my $sver (@svers) {
1448 if (not exists $found_versions{$sver}) {
1449 $found_versions{$sver} = 1;
1450 if (exists $found_removed{$sver}) {
1451 delete $found_removed{$sver};
1454 $found_added{$sver} = 1;
1461 $data->{found_versions} = [keys %found_versions];
1462 $data->{fixed_versions} = [keys %fixed_versions];
1465 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1466 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1467 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1468 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1469 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1471 $action .= " and reopened"
1473 if (not $reopened and not @changed) {
1474 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1475 unless __internal_request();
1479 append_action_to_log(bug => $data->{bug_num},
1482 old_data => $old_data,
1484 __return_append_to_log_options(
1489 if not exists $param{append_log} or $param{append_log};
1490 writebug($data->{bug_num},$data);
1491 print {$transcript} "$action\n";
1493 __end_control(%info);
1499 set_fixed(bug => $ref,
1500 transcript => $transcript,
1501 ($dl > 0 ? (debug => $transcript):()),
1502 requester => $header{from},
1503 request_addr => $controlrequestaddr,
1505 affected_packages => \%affected_packages,
1506 recipients => \%recipients,
1514 print {$transcript} "Failed to set fixed on $ref: $@";
1518 Sets, adds, or removes the specified fixed versions of a package
1520 If the fixed versions are empty (or end up being empty after this
1521 call) or the greatest fixed version is less than the greatest found
1522 version and the reopen option is true, the bug is reopened.
1524 This function is also called by the reopen function, which causes all
1525 of the fixed versions to be cleared.
1530 my %param = validate_with(params => \@_,
1531 spec => {bug => {type => SCALAR,
1534 # specific options here
1535 fixed => {type => SCALAR|ARRAYREF,
1538 add => {type => BOOLEAN,
1541 remove => {type => BOOLEAN,
1544 reopen => {type => BOOLEAN,
1548 %append_action_options,
1551 if ($param{add} and $param{remove}) {
1552 croak "It's nonsensical to add and remove the same versions";
1555 __begin_control(%param,
1558 my ($debug,$transcript) =
1559 @info{qw(debug transcript)};
1560 my @data = @{$info{data}};
1561 my @bugs = @{$info{bugs}};
1563 for my $version (make_list($param{fixed})) {
1564 next unless defined $version;
1565 $versions{$version} =
1566 [make_source_versions(package => [splitpackages($data[0]{package})],
1567 warnings => $transcript,
1570 versions => $version,
1573 # This is really ugly, but it's what we have to do
1574 if (not @{$versions{$version}}) {
1575 print {$transcript} "Unable to make a source version for version '$version'\n";
1578 if (not keys %versions and ($param{remove} or $param{add})) {
1579 if ($param{remove}) {
1580 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1583 print {$transcript} "Requested to add no versions; doing nothing.\n";
1585 __end_control(%info);
1588 # first things first, make the versions fully qualified source
1590 for my $data (@data) {
1591 my $old_data = dclone($data);
1592 # The 'done' field gets a bit weird with version tracking,
1593 # because a bug may be closed by multiple people in different
1594 # branches. Until we have something more flexible, we set it
1595 # every time a bug is fixed, and clear it when a bug is found
1596 # in a version greater than any version in which the bug is
1597 # fixed or when a bug is found and there is no fixed version
1598 my $action = 'Did not alter fixed versions';
1599 my %found_added = ();
1600 my %found_removed = ();
1601 my %fixed_added = ();
1602 my %fixed_removed = ();
1604 if (not $param{add} and not $param{remove}) {
1605 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1606 $data->{fixed_versions} = [];
1609 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1611 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1612 for my $version (keys %versions) {
1614 my @svers = @{$versions{$version}};
1618 for my $sver (@svers) {
1619 if (not exists $fixed_versions{$sver}) {
1620 $fixed_versions{$sver} = 1;
1621 $fixed_added{$sver} = 1;
1625 elsif ($param{remove}) {
1626 # in the case of removal, we only concern ourself with
1627 # the version passed, not the source version it maps
1629 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1630 delete $fixed_versions{$_} for @temp;
1631 $fixed_removed{$_} = 1 for @temp;
1634 # set the keys to exactly these values
1635 my @svers = @{$versions{$version}};
1639 for my $sver (@svers) {
1640 if (not exists $fixed_versions{$sver}) {
1641 $fixed_versions{$sver} = 1;
1642 if (exists $fixed_removed{$sver}) {
1643 delete $fixed_removed{$sver};
1646 $fixed_added{$sver} = 1;
1653 $data->{found_versions} = [keys %found_versions];
1654 $data->{fixed_versions} = [keys %fixed_versions];
1656 # If we're supposed to consider reopening, reopen if the
1657 # fixed versions are empty or the greatest found version
1658 # is greater than the greatest fixed version
1659 if ($param{reopen} and defined $data->{done}
1660 and length $data->{done}) {
1661 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1662 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1663 # determine if we need to reopen
1664 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1665 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1666 if (not @fixed_order or
1667 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1674 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1675 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1676 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1677 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1678 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1680 $action .= " and reopened"
1682 if (not $reopened and not @changed) {
1683 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1684 unless __internal_request();
1688 append_action_to_log(bug => $data->{bug_num},
1691 old_data => $old_data,
1693 __return_append_to_log_options(
1698 if not exists $param{append_log} or $param{append_log};
1699 writebug($data->{bug_num},$data);
1700 print {$transcript} "$action\n";
1702 __end_control(%info);
1710 affects(bug => $ref,
1711 transcript => $transcript,
1712 ($dl > 0 ? (debug => $transcript):()),
1713 requester => $header{from},
1714 request_addr => $controlrequestaddr,
1716 affected_packages => \%affected_packages,
1717 recipients => \%recipients,
1725 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
1728 This marks a bug as affecting packages which the bug is not actually
1729 in. This should only be used in cases where fixing the bug instantly
1730 resolves the problem in the other packages.
1732 By default, the packages are set to the list of packages passed.
1733 However, if you pass add => 1 or remove => 1, the list of packages
1734 passed are added or removed from the affects list, respectively.
1739 my %param = validate_with(params => \@_,
1740 spec => {bug => {type => SCALAR,
1743 # specific options here
1744 packages => {type => SCALAR|ARRAYREF,
1747 add => {type => BOOLEAN,
1750 remove => {type => BOOLEAN,
1754 %append_action_options,
1757 if ($param{add} and $param{remove}) {
1758 croak "Asking to both add and remove affects is nonsensical";
1761 __begin_control(%param,
1762 command => 'affects'
1764 my ($debug,$transcript) =
1765 @info{qw(debug transcript)};
1766 my @data = @{$info{data}};
1767 my @bugs = @{$info{bugs}};
1769 for my $data (@data) {
1771 print {$debug} "Going to change affects\n";
1772 my @packages = splitpackages($data->{affects});
1774 @packages{@packages} = (1) x @packages;
1777 for my $package (make_list($param{packages})) {
1778 next unless defined $package and length $package;
1779 if (not $packages{$package}) {
1780 $packages{$package} = 1;
1781 push @added,$package;
1785 $action = "Added indication that $data->{bug_num} affects ".
1786 english_join(\@added);
1789 elsif ($param{remove}) {
1791 for my $package (make_list($param{packages})) {
1792 if ($packages{$package}) {
1793 next unless defined $package and length $package;
1794 delete $packages{$package};
1795 push @removed,$package;
1798 $action = "Removed indication that $data->{bug_num} affects " .
1799 english_join(\@removed);
1802 my %added_packages = ();
1803 my %removed_packages = %packages;
1805 for my $package (make_list($param{packages})) {
1806 next unless defined $package and length $package;
1807 $packages{$package} = 1;
1808 delete $removed_packages{$package};
1809 $added_packages{$package} = 1;
1811 if (keys %removed_packages) {
1812 $action = "Removed indication that $data->{bug_num} affects ".
1813 english_join([keys %removed_packages]);
1814 $action .= "\n" if keys %added_packages;
1816 if (keys %added_packages) {
1817 $action .= "Added indication that $data->{bug_num} affects " .
1818 english_join([%added_packages]);
1821 if (not length $action) {
1822 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
1823 unless __internal_request();
1825 my $old_data = dclone($data);
1826 $data->{affects} = join(',',keys %packages);
1827 append_action_to_log(bug => $data->{bug_num},
1829 command => 'affects',
1831 old_data => $old_data,
1832 __return_append_to_log_options(
1837 if not exists $param{append_log} or $param{append_log};
1838 writebug($data->{bug_num},$data);
1839 print {$transcript} "$action\n";
1841 __end_control(%info);
1845 =head1 SUMMARY FUNCTIONS
1850 summary(bug => $ref,
1851 transcript => $transcript,
1852 ($dl > 0 ? (debug => $transcript):()),
1853 requester => $header{from},
1854 request_addr => $controlrequestaddr,
1856 affected_packages => \%affected_packages,
1857 recipients => \%recipients,
1863 print {$transcript} "Failed to mark $ref with summary foo: $@";
1866 Handles all setting of summary fields
1868 If summary is undef, unsets the summary
1870 If summary is 0, sets the summary to the first paragraph contained in
1873 If summary is numeric, sets the summary to the message specified.
1880 my %param = validate_with(params => \@_,
1881 spec => {bug => {type => SCALAR,
1884 # specific options here
1885 summary => {type => SCALAR|UNDEF,
1889 %append_action_options,
1892 croak "summary must be numeric or undef" if
1893 defined $param{summary} and not $param{summary} =~ /^\d+$/;
1895 __begin_control(%param,
1896 command => 'summary'
1898 my ($debug,$transcript) =
1899 @info{qw(debug transcript)};
1900 my @data = @{$info{data}};
1901 my @bugs = @{$info{bugs}};
1902 # figure out the log that we're going to use
1904 my $summary_msg = '';
1906 if (not defined $param{summary}) {
1908 print {$debug} "Removing summary fields\n";
1909 $action = 'Removed summary';
1913 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
1914 if ($param{summary} == 0) {
1915 $log = $param{message};
1916 $summary_msg = @records + 1;
1919 if (($param{summary} - 1 ) > $#records) {
1920 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
1922 my $record = $records[($param{summary} - 1 )];
1923 if ($record->{type} !~ /incoming-recv|recips/) {
1924 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
1926 $summary_msg = $param{summary};
1927 $log = [$record->{text}];
1929 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
1930 my $body = $p_o->{body};
1931 my $in_pseudoheaders = 0;
1933 # walk through body until we get non-blank lines
1934 for my $line (@{$body}) {
1935 if ($line =~ /^\s*$/) {
1936 if (length $paragraph) {
1937 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
1943 $in_pseudoheaders = 0;
1946 # skip a paragraph if it looks like it's control or
1948 if ($line =~ m{^\s*(?:(?:Package|Source|Version)\:| #pseudo headers
1949 (?:package|(?:no|)owner|severity|tag|summary| #control
1950 reopen|close|(?:not|)(?:fixed|found)|clone|
1951 (?:force|)merge|user(?:category|tag|)
1954 if (not length $paragraph) {
1955 print {$debug} "Found control/pseudo-headers and skiping them\n";
1956 $in_pseudoheaders = 1;
1960 next if $in_pseudoheaders;
1961 $paragraph .= $line ." \n";
1963 print {$debug} "Summary is going to be '$paragraph'\n";
1964 $summary = $paragraph;
1965 $summary =~ s/[\n\r]/ /g;
1966 if (not length $summary) {
1967 die "Unable to find summary message to use";
1969 # trim off a trailing spaces
1970 $summary =~ s/\ *$//;
1972 for my $data (@data) {
1973 print {$debug} "Going to change summary\n";
1974 if (((not defined $summary or not length $summary) and
1975 (not defined $data->{summary} or not length $data->{summary})) or
1976 $summary eq $data->{summary}) {
1977 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1978 unless __internal_request();
1981 if (length $summary) {
1982 if (length $data->{summary}) {
1983 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1986 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1989 my $old_data = dclone($data);
1990 $data->{summary} = $summary;
1991 append_action_to_log(bug => $data->{bug_num},
1992 command => 'summary',
1993 old_data => $old_data,
1996 __return_append_to_log_options(
2001 if not exists $param{append_log} or $param{append_log};
2002 writebug($data->{bug_num},$data);
2003 print {$transcript} "$action\n";
2005 __end_control(%info);
2011 =head1 OWNER FUNCTIONS
2017 transcript => $transcript,
2018 ($dl > 0 ? (debug => $transcript):()),
2019 requester => $header{from},
2020 request_addr => $controlrequestaddr,
2022 recipients => \%recipients,
2028 print {$transcript} "Failed to mark $ref as having an owner: $@";
2031 Handles all setting of the owner field; given an owner of undef or of
2032 no length, indicates that a bug is not owned by anyone.
2037 my %param = validate_with(params => \@_,
2038 spec => {bug => {type => SCALAR,
2041 owner => {type => SCALAR|UNDEF,
2044 %append_action_options,
2048 __begin_control(%param,
2051 my ($debug,$transcript) =
2052 @info{qw(debug transcript)};
2053 my @data = @{$info{data}};
2054 my @bugs = @{$info{bugs}};
2056 for my $data (@data) {
2057 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2058 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2059 if (not defined $param{owner} or not length $param{owner}) {
2060 if (not defined $data->{owner} or not length $data->{owner}) {
2061 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2062 unless __internal_request();
2066 $action = "Removed annotation that $config{bug} was owned by " .
2070 if ($data->{owner} eq $param{owner}) {
2071 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2074 if (length $data->{owner}) {
2075 $action = "Owner changed from $data->{owner} to $param{owner}.";
2078 $action = "Owner recorded as $param{owner}."
2081 my $old_data = dclone($data);
2082 $data->{owner} = $param{owner};
2083 append_action_to_log(bug => $data->{bug_num},
2086 old_data => $old_data,
2088 __return_append_to_log_options(
2093 if not exists $param{append_log} or $param{append_log};
2094 writebug($data->{bug_num},$data);
2095 print {$transcript} "$action\n";
2097 __end_control(%info);
2101 =head1 ARCHIVE FUNCTIONS
2108 bug_archive(bug => $bug_num,
2110 transcript => \$transcript,
2115 transcript("Unable to archive $bug_num\n");
2118 transcript($transcript);
2121 This routine archives a bug
2125 =item bug -- bug number
2127 =item check_archiveable -- check wether a bug is archiveable before
2128 archiving; defaults to 1
2130 =item archive_unarchived -- whether to archive bugs which have not
2131 previously been archived; defaults to 1. [Set to 0 when used from
2134 =item ignore_time -- whether to ignore time constraints when archiving
2135 a bug; defaults to 0.
2142 my %param = validate_with(params => \@_,
2143 spec => {bug => {type => SCALAR,
2146 check_archiveable => {type => BOOLEAN,
2149 archive_unarchived => {type => BOOLEAN,
2152 ignore_time => {type => BOOLEAN,
2156 %append_action_options,
2159 my %info = __begin_control(%param,
2160 command => 'archive',
2162 my ($debug,$transcript) = @info{qw(debug transcript)};
2163 my @data = @{$info{data}};
2164 my @bugs = @{$info{bugs}};
2165 my $action = "$config{bug} archived.";
2166 if ($param{check_archiveable} and
2167 not bug_archiveable(bug=>$param{bug},
2168 ignore_time => $param{ignore_time},
2170 print {$transcript} "Bug $param{bug} cannot be archived\n";
2171 die "Bug $param{bug} cannot be archived";
2173 print {$debug} "$param{bug} considering\n";
2174 if (not $param{archive_unarchived} and
2175 not exists $data[0]{unarchived}
2177 print {$transcript} "$param{bug} has not been archived previously\n";
2178 die "$param{bug} has not been archived previously";
2180 add_recipients(recipients => $param{recipients},
2183 transcript => $transcript,
2185 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2186 for my $bug (@bugs) {
2187 if ($param{check_archiveable}) {
2188 die "Bug $bug cannot be archived (but $param{bug} can?)"
2189 unless bug_archiveable(bug=>$bug,
2190 ignore_time => $param{ignore_time},
2194 # If we get here, we can archive/remove this bug
2195 print {$debug} "$param{bug} removing\n";
2196 for my $bug (@bugs) {
2197 #print "$param{bug} removing $bug\n" if $debug;
2198 my $dir = get_hashname($bug);
2199 # First indicate that this bug is being archived
2200 append_action_to_log(bug => $bug,
2202 command => 'archive',
2203 # we didn't actually change the data
2204 # when we archived, so we don't pass
2205 # a real new_data or old_data
2208 __return_append_to_log_options(
2213 if not exists $param{append_log} or $param{append_log};
2214 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2215 if ($config{save_old_bugs}) {
2216 mkpath("$config{spool_dir}/archive/$dir");
2217 foreach my $file (@files_to_remove) {
2218 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2219 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2220 # we need to bail out here if things have
2221 # gone horribly wrong to avoid removing a
2223 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2226 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2228 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2229 print {$transcript} "deleted $bug (from $param{bug})\n";
2231 bughook_archive(@bugs);
2232 __end_control(%info);
2235 =head2 bug_unarchive
2239 bug_unarchive(bug => $bug_num,
2241 transcript => \$transcript,
2246 transcript("Unable to archive bug: $bug_num");
2248 transcript($transcript);
2250 This routine unarchives a bug
2255 my %param = validate_with(params => \@_,
2256 spec => {bug => {type => SCALAR,
2260 %append_action_options,
2264 my %info = __begin_control(%param,
2266 command=>'unarchive');
2267 my ($debug,$transcript) =
2268 @info{qw(debug transcript)};
2269 my @data = @{$info{data}};
2270 my @bugs = @{$info{bugs}};
2271 my $action = "$config{bug} unarchived.";
2272 my @files_to_remove;
2273 for my $bug (@bugs) {
2274 print {$debug} "$param{bug} removing $bug\n";
2275 my $dir = get_hashname($bug);
2276 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
2277 mkpath("archive/$dir");
2278 foreach my $file (@files_to_copy) {
2279 # die'ing here sucks
2280 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2281 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2282 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
2284 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
2285 print {$transcript} "Unarchived $config{bug} $bug\n";
2287 unlink(@files_to_remove) or die "Unable to unlink bugs";
2288 # Indicate that this bug has been archived previously
2289 for my $bug (@bugs) {
2290 my $newdata = readbug($bug);
2291 my $old_data = dclone($newdata);
2292 if (not defined $newdata) {
2293 print {$transcript} "$config{bug} $bug disappeared!\n";
2294 die "Bug $bug disappeared!";
2296 $newdata->{unarchived} = time;
2297 append_action_to_log(bug => $bug,
2299 command => 'unarchive',
2300 new_data => $newdata,
2301 old_data => $old_data,
2302 __return_append_to_log_options(
2307 if not exists $param{append_log} or $param{append_log};
2308 writebug($bug,$newdata);
2310 __end_control(%info);
2313 =head2 append_action_to_log
2315 append_action_to_log
2317 This should probably be moved to Debbugs::Log; have to think that out
2322 sub append_action_to_log{
2323 my %param = validate_with(params => \@_,
2324 spec => {bug => {type => SCALAR,
2327 new_data => {type => HASHREF,
2330 old_data => {type => HASHREF,
2333 command => {type => SCALAR,
2336 action => {type => SCALAR,
2338 requester => {type => SCALAR,
2341 request_addr => {type => SCALAR,
2344 location => {type => SCALAR,
2347 message => {type => SCALAR|ARRAYREF,
2350 desc => {type => SCALAR,
2353 get_lock => {type => BOOLEAN,
2357 # append_action_options here
2358 # because some of these
2359 # options aren't actually
2360 # optional, even though the
2361 # original function doesn't
2365 # Fix this to use $param{location}
2366 my $log_location = buglog($param{bug});
2367 die "Unable to find .log for $param{bug}"
2368 if not defined $log_location;
2369 if ($param{get_lock}) {
2370 filelock("lock/$param{bug}");
2372 my $log = IO::File->new(">>$log_location") or
2373 die "Unable to open $log_location for appending: $!";
2374 # determine difference between old and new
2376 if (exists $param{old_data} and exists $param{new_data}) {
2377 my $old_data = dclone($param{old_data});
2378 my $new_data = dclone($param{new_data});
2379 for my $key (keys %{$old_data}) {
2380 if (not exists $Debbugs::Status::fields{$key}) {
2381 delete $old_data->{$key};
2384 next unless exists $new_data->{$key};
2385 next unless defined $new_data->{$key};
2386 if (not defined $old_data->{$key}) {
2387 delete $old_data->{$key};
2390 if (ref($new_data->{$key}) and
2391 ref($old_data->{$key}) and
2392 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2393 local $Storable::canonical = 1;
2394 # print STDERR Dumper($new_data,$old_data,$key);
2395 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2396 delete $new_data->{$key};
2397 delete $old_data->{$key};
2400 elsif ($new_data->{$key} eq $old_data->{$key}) {
2401 delete $new_data->{$key};
2402 delete $old_data->{$key};
2405 for my $key (keys %{$new_data}) {
2406 if (not exists $Debbugs::Status::fields{$key}) {
2407 delete $new_data->{$key};
2410 next unless exists $old_data->{$key};
2411 next unless defined $old_data->{$key};
2412 if (not defined $new_data->{$key} or
2413 not exists $Debbugs::Status::fields{$key}) {
2414 delete $new_data->{$key};
2417 if (ref($new_data->{$key}) and
2418 ref($old_data->{$key}) and
2419 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2420 local $Storable::canonical = 1;
2421 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2422 delete $new_data->{$key};
2423 delete $old_data->{$key};
2426 elsif ($new_data->{$key} eq $old_data->{$key}) {
2427 delete $new_data->{$key};
2428 delete $old_data->{$key};
2431 $data_diff .= "<!-- new_data:\n";
2433 for my $key (keys %{$new_data}) {
2434 if (not exists $Debbugs::Status::fields{$key}) {
2435 warn "No such field $key";
2438 $nd{$key} = $new_data->{$key};
2439 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
2441 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
2442 $data_diff .= "-->\n";
2443 $data_diff .= "<!-- old_data:\n";
2445 for my $key (keys %{$old_data}) {
2446 if (not exists $Debbugs::Status::fields{$key}) {
2447 warn "No such field $key";
2450 $od{$key} = $old_data->{$key};
2451 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
2453 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
2454 $data_diff .= "-->\n";
2456 my $msg = join('',"\6\n",
2457 (exists $param{command} ?
2458 "<!-- command:".html_escape($param{command})." -->\n":""
2460 (length $param{requester} ?
2461 "<!-- requester: ".html_escape($param{requester})." -->\n":""
2463 (length $param{request_addr} ?
2464 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
2466 "<!-- time:".time()." -->\n",
2468 "<strong>".html_escape($param{action})."</strong>\n");
2469 if (length $param{requester}) {
2470 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
2472 if (length $param{request_addr}) {
2473 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
2475 if (length $param{desc}) {
2476 $msg .= ":<br>\n$param{desc}\n";
2482 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
2483 $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
2484 or die "Unable to append to $log_location: $!";
2486 print {$log} $msg or die "Unable to append to $log_location: $!";
2487 close $log or die "Unable to close $log_location: $!";
2488 if ($param{get_lock}) {
2496 =head1 PRIVATE FUNCTIONS
2498 =head2 __handle_affected_packages
2500 __handle_affected_packages(affected_packages => {},
2508 sub __handle_affected_packages{
2509 my %param = validate_with(params => \@_,
2510 spec => {%common_options,
2511 data => {type => ARRAYREF|HASHREF
2516 for my $data (make_list($param{data})) {
2517 next unless exists $data->{package} and defined $data->{package};
2518 my @packages = split /\s*,\s*/,$data->{package};
2519 @{$param{affected_packages}}{@packages} = (1) x @packages;
2523 =head2 __handle_debug_transcript
2525 my ($debug,$transcript) = __handle_debug_transcript(%param);
2527 Returns a debug and transcript filehandle
2532 sub __handle_debug_transcript{
2533 my %param = validate_with(params => \@_,
2534 spec => {%common_options},
2537 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
2538 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
2539 return ($debug,$transcript);
2546 Produces a small bit of bug information to kick out to the transcript
2553 next unless defined $data and exists $data->{bug_num};
2554 $return .= "Bug #".($data->{bug_num}||'').
2555 ((defined $data->{done} and length $data->{done})?
2556 " {Done: $data->{done}}":''
2558 " [".($data->{package}||'(no package)'). "] ".
2559 ($data->{subject}||'(no subject)')."\n";
2565 =head2 __internal_request
2567 __internal_request()
2568 __internal_request($level)
2570 Returns true if the caller of the function calling __internal_request
2571 belongs to __PACKAGE__
2573 This allows us to be magical, and don't bother to print bug info if
2574 the second caller is from this package, amongst other things.
2576 An optional level is allowed, which increments the number of levels to
2577 check by the given value. [This is basically for use by internal
2578 functions like __begin_control which are always called by
2583 sub __internal_request{
2585 $l = 0 if not defined $l;
2586 if (defined +(caller(2+$l))[0] and +(caller(2+$l))[0] eq __PACKAGE__) {
2592 sub __return_append_to_log_options{
2594 my $action = $param{action} if exists $param{action};
2595 if (not exists $param{requester}) {
2596 $param{requester} = $config{control_internal_requester};
2598 if (not exists $param{request_addr}) {
2599 $param{request_addr} = $config{control_internal_request_addr};
2601 if (not exists $param{message}) {
2602 my $date = rfc822_date();
2603 $param{message} = fill_in_template(template => 'mail/fake_control_message',
2604 variables => {request_addr => $param{request_addr},
2605 requester => $param{requester},
2611 if (not defined $action) {
2612 carp "Undefined action!";
2613 $action = "unknown action";
2615 return (action => $action,
2616 (map {exists $append_action_options{$_}?($_,$param{$_}):()}
2621 =head2 __begin_control
2623 my %info = __begin_control(%param,
2625 command=>'unarchive');
2626 my ($debug,$transcript) = @info{qw(debug transcript)};
2627 my @data = @{$info{data}};
2628 my @bugs = @{$info{bugs}};
2631 Starts the process of modifying a bug; handles all of the generic
2632 things that almost every control request needs
2634 Returns a hash containing
2638 =item new_locks -- number of new locks taken out by this call
2640 =item debug -- the debug file handle
2642 =item transcript -- the transcript file handle
2644 =item data -- an arrayref containing the data of the bugs
2645 corresponding to this request
2647 =item bugs -- an arrayref containing the bug numbers of the bugs
2648 corresponding to this request
2656 sub __begin_control {
2657 my %param = validate_with(params => \@_,
2658 spec => {bug => {type => SCALAR,
2661 archived => {type => BOOLEAN,
2664 command => {type => SCALAR,
2672 my ($debug,$transcript) = __handle_debug_transcript(@_);
2673 print {$debug} "$param{bug} considering\n";
2675 my $old_die = $SIG{__DIE__};
2676 $SIG{__DIE__} = *sig_die{CODE};
2678 ($new_locks, @data) =
2679 lock_read_all_merged_bugs($param{bug},
2680 ($param{archived}?'archive':()));
2681 $locks += $new_locks;
2683 die "Unable to read any bugs successfully.";
2686 # XXX check the limit at this point, and die if it is exceeded.
2687 # This is currently not done
2689 __handle_affected_packages(%param,data => \@data);
2690 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2691 print {$debug} "$param{bug} read $locks locks\n";
2692 if (not @data or not defined $data[0]) {
2693 print {$transcript} "No bug found for $param{bug}\n";
2694 die "No bug found for $param{bug}";
2697 add_recipients(data => \@data,
2698 recipients => $param{recipients},
2699 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2701 transcript => $transcript,
2704 print {$debug} "$param{bug} read done\n";
2705 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2706 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2707 return (data => \@data,
2709 old_die => $old_die,
2710 new_locks => $new_locks,
2712 transcript => $transcript,
2717 =head2 __end_control
2719 __end_control(%info);
2721 Handles tearing down from a control request
2727 if (exists $info{new_locks} and $info{new_locks} > 0) {
2728 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2729 for (1..$info{new_locks}) {
2733 $SIG{__DIE__} = $info{old_die};
2734 if (exists $info{param}{bugs_affected}) {
2735 @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2737 add_recipients(recipients => $info{param}{recipients},
2738 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
2739 data => $info{data},
2740 debug => $info{debug},
2741 transcript => $info{transcript},
2743 __handle_affected_packages(%{$info{param}},data=>$info{data});
2751 We override die to specially handle unlocking files in the cases where
2752 we are called via eval. [If we're not called via eval, it doesn't
2758 #if ($^S) { # in eval
2760 for (1..$locks) { unfilelock(); }
2767 # =head2 __message_body_template
2769 # message_body_template('mail/ack',{ref=>'foo'});
2771 # Creates a message body using a template
2775 sub __message_body_template{
2776 my ($template,$extra_var) = @_;
2778 my $hole_var = {'&bugurl' =>
2780 'http://'.$config{cgi_domain}.'/'.
2781 Debbugs::CGI::bug_url($_[0]);
2785 my $body = fill_in_template(template => $template,
2786 variables => {config => \%config,
2789 hole_var => $hole_var,
2791 return fill_in_template(template => 'mail/message_body',
2792 variables => {config => \%config,
2796 hole_var => $hole_var,