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)],
98 archive => [qw(bug_archive bug_unarchive),
100 log => [qw(append_action_to_log),
104 Exporter::export_ok_tags(keys %EXPORT_TAGS);
105 $EXPORT_TAGS{all} = [@EXPORT_OK];
108 use Debbugs::Config qw(:config);
109 use Debbugs::Common qw(:lock buglog :misc get_hashname);
110 use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages split_status_fields);
111 use Debbugs::CGI qw(html_escape);
112 use Debbugs::Log qw(:misc);
113 use Debbugs::Recipients qw(:add);
114 use Debbugs::Packages qw(:versions :mapping);
116 use Params::Validate qw(validate_with :types);
117 use File::Path qw(mkpath);
120 use Debbugs::Text qw(:templates);
122 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
123 use Debbugs::MIME qw(create_mime_message);
125 use Mail::RFC822::Address qw();
127 use POSIX qw(strftime);
129 use Storable qw(dclone nfreeze);
130 use List::Util qw(first);
134 # These are a set of options which are common to all of these functions
136 my %common_options = (debug => {type => SCALARREF|HANDLE,
139 transcript => {type => SCALARREF|HANDLE,
142 affected_bugs => {type => HASHREF,
145 affected_packages => {type => HASHREF,
148 recipients => {type => HASHREF,
151 limit => {type => HASHREF,
154 show_bug_info => {type => BOOLEAN,
157 request_subject => {type => SCALAR,
158 default => 'Unknown Subject',
160 request_msgid => {type => SCALAR,
163 request_nn => {type => SCALAR,
166 request_replyto => {type => SCALAR,
172 my %append_action_options =
173 (action => {type => SCALAR,
176 requester => {type => SCALAR,
179 request_addr => {type => SCALAR,
182 location => {type => SCALAR,
185 message => {type => SCALAR|ARRAYREF,
188 append_log => {type => BOOLEAN,
190 depends => [qw(requester request_addr),
197 # this is just a generic stub for Debbugs::Control functions.
202 # set_foo(bug => $ref,
203 # transcript => $transcript,
204 # ($dl > 0 ? (debug => $transcript):()),
205 # requester => $header{from},
206 # request_addr => $controlrequestaddr,
208 # affected_packages => \%affected_packages,
209 # recipients => \%recipients,
215 # print {$transcript} "Failed to set foo $ref bar: $@";
223 # my %param = validate_with(params => \@_,
224 # spec => {bug => {type => SCALAR,
225 # regex => qr/^\d+$/,
227 # # specific options here
229 # %append_action_options,
233 # __begin_control(%param,
236 # my ($debug,$transcript) =
237 # @info{qw(debug transcript)};
238 # my @data = @{$info{data}};
239 # my @bugs = @{$info{bugs}};
242 # for my $data (@data) {
243 # append_action_to_log(bug => $data->{bug_num},
245 # __return_append_to_log_options(
250 # if not exists $param{append_log} or $param{append_log};
251 # writebug($data->{bug_num},$data);
252 # print {$transcript} "$action\n";
254 # __end_control(%info);
261 set_block(bug => $ref,
262 transcript => $transcript,
263 ($dl > 0 ? (debug => $transcript):()),
264 requester => $header{from},
265 request_addr => $controlrequestaddr,
267 affected_packages => \%affected_packages,
268 recipients => \%recipients,
274 print {$transcript} "Failed to set blockers of $ref: $@";
277 Alters the set of bugs that block this bug from being fixed
279 This requires altering both this bug (and those it's merged with) as
280 well as the bugs that block this bug from being fixed (and those that
285 =item block -- scalar or arrayref of blocking bugs to set, add or remove
287 =item add -- if true, add blocking bugs
289 =item remove -- if true, remove blocking bugs
296 my %param = validate_with(params => \@_,
297 spec => {bug => {type => SCALAR,
300 # specific options here
301 block => {type => SCALAR|ARRAYREF,
304 add => {type => BOOLEAN,
307 remove => {type => BOOLEAN,
311 %append_action_options,
314 if ($param{add} and $param{remove}) {
315 croak "It's nonsensical to add and remove the same blocking bugs";
317 if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
318 croak "Invalid blocking bug(s):".
319 join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
325 elsif ($param{remove}) {
330 __begin_control(%param,
333 my ($debug,$transcript) =
334 @info{qw(debug transcript)};
335 my @data = @{$info{data}};
336 my @bugs = @{$info{bugs}};
339 # The first bit of this code is ugly, and should be cleaned up.
340 # Its purpose is to populate %removed_blockers and %add_blockers
341 # with all of the bugs that should be added or removed as blockers
342 # of all of the bugs which are merged with $param{bug}
345 for my $blocker (make_list($param{block})) {
346 next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
347 my $data = read_bug(bug=>$blocker,
349 if (defined $data and not $data->{archive}) {
350 $data = split_status_fields($data);
351 $ok_blockers{$blocker} = 1;
353 push @merged_bugs, make_list($data->{mergedwith});
354 @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
357 $bad_blockers{$blocker} = 1;
361 # throw an error if we are setting the blockers and there is a bad
363 if (keys %bad_blockers and $mode eq 'set') {
364 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
365 keys %ok_blockers?'':" and no known blocking bug(s)";
367 # if there are no ok blockers and we are not setting the blockers,
369 if (not keys %ok_blockers and $mode ne 'set') {
370 print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
371 if (keys %bad_blockers) {
372 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
374 __end_control(%info);
378 my @change_blockers = keys %ok_blockers;
380 my %removed_blockers;
383 my @blockers = map {split ' ', $_->{blockedby}} @data;
385 @blockers{@blockers} = (1) x @blockers;
387 # it is nonsensical for a bug to block itself (or a merged
388 # partner); We currently don't allow removal because we'd possibly
392 @bugs{@bugs} = (1) x @bugs;
393 for my $blocker (@change_blockers) {
394 if ($bugs{$blocker}) {
395 croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
398 @blockers = keys %blockers;
400 %removed_blockers = ();
401 for my $blocker (@change_blockers) {
402 next if exists $blockers{$blocker};
403 $blockers{$blocker} = 1;
404 $added_blockers{$blocker} = 1;
407 elsif ($param{remove}) {
408 %added_blockers = ();
409 for my $blocker (@change_blockers) {
410 next if exists $removed_blockers{$blocker};
411 delete $blockers{$blocker};
412 $removed_blockers{$blocker} = 1;
416 @removed_blockers{@blockers} = (1) x @blockers;
418 for my $blocker (@change_blockers) {
419 next if exists $blockers{$blocker};
420 $blockers{$blocker} = 1;
421 if (exists $removed_blockers{$blocker}) {
422 delete $removed_blockers{$blocker};
425 $added_blockers{$blocker} = 1;
429 my @new_blockers = keys %blockers;
430 for my $data (@data) {
431 my $old_data = dclone($data);
432 # remove blockers and/or add new ones as appropriate
433 if ($data->{blockedby} eq '') {
434 print {$transcript} "Was not blocked by any bugs.\n";
436 print {$transcript} "Was blocked by: $data->{blockedby}\n";
439 push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
440 push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers;
441 $action = ucfirst(join ('; ',@changed)) if @changed;
443 print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n"
444 unless __internal_request();
447 $data->{blockedby} = join(' ',keys %blockers);
448 append_action_to_log(bug => $data->{bug_num},
450 old_data => $old_data,
453 __return_append_to_log_options(
458 if not exists $param{append_log} or $param{append_log};
459 writebug($data->{bug_num},$data);
460 print {$transcript} "$action\n";
462 # we do this bit below to avoid code duplication
464 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
465 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
466 for my $add_remove (keys %mungable_blocks) {
470 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
471 next if $munge_blockers{$blocker};
472 my ($new_locks, @blocking_data) =
473 lock_read_all_merged_bugs($blocker,
474 ($param{archived}?'archive':()));
475 if (not @blocking_data) {
476 unfilelock() for $new_locks;
477 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
479 for (map {$_->{bug_num}} @blocking_data) {
480 $munge_blockers{$_} = 1;
482 for my $data (@blocking_data) {
483 my $old_data = dclone($data);
485 my @blocks = split ' ', $data->{blocks};
486 @blocks{@blocks} = (1) x @blocks;
488 for my $bug (@bugs) {
489 if ($add_remove eq 'remove') {
490 next unless exists $blocks{$bug};
491 delete $blocks{$bug};
494 next if exists $blocks{$bug};
499 $data->{blocks} = join(' ',sort keys %blocks);
500 my $action = ($add_remove eq 'add'?'Added':'Removed').
501 " indication that bug $data->{bug_num} blocks ".
503 append_action_to_log(bug => $data->{bug_num},
505 old_data => $old_data,
508 __return_append_to_log_options(%param,
512 writebug($data->{bug_num},$data);
514 __handle_affected_packages(%param,data=>\@blocking_data);
515 add_recipients(recipients => $param{recipients},
516 actions_taken => {blocks => 1},
517 data => \@blocking_data,
519 transcript => $transcript,
522 unfilelock() for $new_locks;
525 __end_control(%info);
534 transcript => $transcript,
535 ($dl > 0 ? (debug => $transcript):()),
536 requester => $header{from},
537 request_addr => $controlrequestaddr,
539 affected_packages => \%affected_packages,
540 recipients => \%recipients,
547 print {$transcript} "Failed to set tag on $ref: $@";
551 Sets, adds, or removes the specified tags on a bug
555 =item tag -- scalar or arrayref of tags to set, add or remove
557 =item add -- if true, add tags
559 =item remove -- if true, remove tags
561 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
569 my %param = validate_with(params => \@_,
570 spec => {bug => {type => SCALAR,
573 # specific options here
574 tag => {type => SCALAR|ARRAYREF,
577 add => {type => BOOLEAN,
580 remove => {type => BOOLEAN,
583 warn_on_bad_tags => {type => BOOLEAN,
587 %append_action_options,
590 if ($param{add} and $param{remove}) {
591 croak "It's nonsensical to add and remove the same tags";
595 __begin_control(%param,
598 my ($debug,$transcript) =
599 @info{qw(debug transcript)};
600 my @data = @{$info{data}};
601 my @bugs = @{$info{bugs}};
602 my @tags = make_list($param{tag});
603 if (not @tags and ($param{remove} or $param{add})) {
604 if ($param{remove}) {
605 print {$transcript} "Requested to remove no tags; doing nothing.\n";
608 print {$transcript} "Requested to add no tags; doing nothing.\n";
610 __end_control(%info);
613 # first things first, make the versions fully qualified source
615 for my $data (@data) {
616 my $action = 'Did not alter tags';
618 my %tag_removed = ();
619 my %fixed_removed = ();
620 my @old_tags = split /\,?\s+/, $data->{keywords};
622 @tags{@old_tags} = (1) x @old_tags;
624 my $old_data = dclone($data);
625 if (not $param{add} and not $param{remove}) {
626 $tag_removed{$_} = 1 for @old_tags;
630 for my $tag (@tags) {
631 if (not $param{remove} and
632 not defined first {$_ eq $tag} @{$config{tags}}) {
633 push @bad_tags, $tag;
637 if (not exists $tags{$tag}) {
639 $tag_added{$tag} = 1;
642 elsif ($param{remove}) {
643 if (exists $tags{$tag}) {
645 $tag_removed{$tag} = 1;
649 if (exists $tag_removed{$tag}) {
650 delete $tag_removed{$tag};
653 $tag_added{$tag} = 1;
658 if (@bad_tags and $param{warn_on_bad_tags}) {
659 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
660 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
662 $data->{keywords} = join(' ',keys %tags);
665 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
666 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
667 $action = ucfirst(join ('; ',@changed)) if @changed;
669 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
670 unless __internal_request();
674 append_action_to_log(bug => $data->{bug_num},
677 old_data => $old_data,
679 __return_append_to_log_options(
684 if not exists $param{append_log} or $param{append_log};
685 writebug($data->{bug_num},$data);
686 print {$transcript} "$action\n";
688 __end_control(%info);
696 set_severity(bug => $ref,
697 transcript => $transcript,
698 ($dl > 0 ? (debug => $transcript):()),
699 requester => $header{from},
700 request_addr => $controlrequestaddr,
702 affected_packages => \%affected_packages,
703 recipients => \%recipients,
704 severity => 'normal',
709 print {$transcript} "Failed to set the severity of bug $ref: $@";
712 Sets the severity of a bug. If severity is not passed, is undefined,
713 or has zero length, sets the severity to the defafult severity.
718 my %param = validate_with(params => \@_,
719 spec => {bug => {type => SCALAR,
722 # specific options here
723 severity => {type => SCALAR|UNDEF,
724 default => $config{default_severity},
727 %append_action_options,
730 if (not defined $param{severity} or
731 not length $param{severity}
733 $param{severity} = $config{default_severity};
736 # check validity of new severity
737 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
738 die "Severity '$param{severity}' is not a valid severity level";
741 __begin_control(%param,
742 command => 'severity'
744 my ($debug,$transcript) =
745 @info{qw(debug transcript)};
746 my @data = @{$info{data}};
747 my @bugs = @{$info{bugs}};
750 for my $data (@data) {
751 if (not defined $data->{severity}) {
752 $data->{severity} = $param{severity};
753 $action = "Severity set to '$param{severity}'\n";
756 if ($data->{severity} eq '') {
757 $data->{severity} = $config{default_severity};
759 if ($data->{severity} eq $param{severity}) {
760 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
763 $action = "Severity set to '$param{severity}' from '$data->{severity}'\n";
764 $data->{severity} = $param{severity};
766 append_action_to_log(bug => $data->{bug_num},
768 __return_append_to_log_options(
773 if not exists $param{append_log} or $param{append_log};
774 writebug($data->{bug_num},$data);
775 print {$transcript} "$action\n";
777 __end_control(%info);
785 transcript => $transcript,
786 ($dl > 0 ? (debug => $transcript):()),
787 requester => $header{from},
788 request_addr => $controlrequestaddr,
790 affected_packages => \%affected_packages,
791 recipients => \%recipients,
797 print {$transcript} "Failed to set foo $ref bar: $@";
805 my %param = validate_with(params => \@_,
806 spec => {bug => {type => SCALAR,
809 # specific options here
810 submitter => {type => SCALAR|UNDEF,
814 %append_action_options,
818 $param{submitter} = undef if defined $param{submitter} and
819 not length $param{submitter};
821 if (defined $param{submitter} and
822 not Mail::RFC822::Address::valid($param{submitter})) {
823 die "New submitter address $param{submitter} is not a valid e-mail address";
827 __begin_control(%param,
830 my ($debug,$transcript) =
831 @info{qw(debug transcript)};
832 my @data = @{$info{data}};
833 my @bugs = @{$info{bugs}};
836 my $warn_fixed = 1; # avoid warning multiple times if there are
838 my @change_submitter = ();
839 my @bugs_to_reopen = ();
840 for my $data (@data) {
841 if (not exists $data->{done} or
842 not defined $data->{done} or
843 not length $data->{done}) {
844 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
845 __end_control(%info);
848 if (@{$data->{fixed_versions}} and $warn_fixed) {
849 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
850 print {$transcript} "you may need to use 'found' to remove fixed versions.\n";
853 if (defined $param{submitter} and length $param{submitter}
854 and $data->{originator} ne $param{submitter}) {
855 push @change_submitter,$data->{bug_num};
858 __end_control(%info);
859 my @params_for_subcalls =
860 map {exists $param{$_}?($_,$param{$_}):()}
861 (keys %common_options,
862 keys %append_action_options,
865 for my $bug (@change_submitter) {
866 set_submitter(bug=>$bug,
867 submitter => $param{submitter},
868 @params_for_subcalls,
871 set_fixed(fixed => [],
881 set_submitter(bug => $ref,
882 transcript => $transcript,
883 ($dl > 0 ? (debug => $transcript):()),
884 requester => $header{from},
885 request_addr => $controlrequestaddr,
887 affected_packages => \%affected_packages,
888 recipients => \%recipients,
889 submitter => $new_submitter,
890 notify_submitter => 1,
895 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
898 Sets the submitter of a bug. If notify_submitter is true (the
899 default), notifies the old submitter of a bug on changes
904 my %param = validate_with(params => \@_,
905 spec => {bug => {type => SCALAR,
908 # specific options here
909 submitter => {type => SCALAR,
911 notify_submitter => {type => BOOLEAN,
915 %append_action_options,
918 if (not Mail::RFC822::Address::valid($param{submitter})) {
919 die "New submitter address $param{submitter} is not a valid e-mail address";
922 __begin_control(%param,
923 command => 'submitter'
925 my ($debug,$transcript) =
926 @info{qw(debug transcript)};
927 my @data = @{$info{data}};
928 my @bugs = @{$info{bugs}};
930 # here we only concern ourselves with the first of the merged bugs
931 for my $data ($data[0]) {
932 my $notify_old_submitter = 0;
933 my $old_data = dclone($data);
934 print {$debug} "Going to change bug submitter\n";
935 if (((not defined $param{submitter} or not length $param{submitter}) and
936 (not defined $data->{originator} or not length $data->{originator})) or
937 (defined $param{submitter} and defined $data->{originator} and
938 $param{submitter} eq $data->{originator})) {
939 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
940 unless __internal_request();
944 if (defined $data->{originator} and length($data->{originator})) {
945 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
946 $notify_old_submitter = 1;
949 $action= "Set $config{bug} submitter to '$param{submitter}'.";
951 $data->{originator} = $param{submitter};
953 append_action_to_log(bug => $data->{bug_num},
954 command => 'submitter',
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 print {$transcript} "$action\n";
966 # notify old submitter
967 if ($notify_old_submitter and $param{notify_submitter}) {
968 send_mail_message(message =>
969 create_mime_message([default_headers(queue_file => $param{request_nn},
971 msgid => $param{request_msgid},
973 pr_msg => 'submitter-changed',
975 [To => $old_data->{submitter},
976 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
980 __message_body_template('mail/submitter_changed',
981 {old_data => $old_data,
983 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
987 recipients => $old_data->{submitter},
991 __end_control(%info);
999 set_forwarded(bug => $ref,
1000 transcript => $transcript,
1001 ($dl > 0 ? (debug => $transcript):()),
1002 requester => $header{from},
1003 request_addr => $controlrequestaddr,
1005 affected_packages => \%affected_packages,
1006 recipients => \%recipients,
1007 forwarded => $forward_to,
1012 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1015 Sets the location to which a bug is forwarded. Given an undef
1016 forwarded, unsets forwarded.
1022 my %param = validate_with(params => \@_,
1023 spec => {bug => {type => SCALAR,
1026 # specific options here
1027 forwarded => {type => SCALAR|UNDEF,
1030 %append_action_options,
1033 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1034 die "Non-printable characters are not allowed in the forwarded field";
1037 __begin_control(%param,
1038 command => 'forwarded'
1040 my ($debug,$transcript) =
1041 @info{qw(debug transcript)};
1042 my @data = @{$info{data}};
1043 my @bugs = @{$info{bugs}};
1045 for my $data (@data) {
1046 my $old_data = dclone($data);
1047 print {$debug} "Going to change bug forwarded\n";
1048 if (((not defined $param{forwarded} or not length $param{forwarded}) and
1049 (not defined $data->{forwarded} or not length $data->{forwarded})) or
1050 $param{forwarded} eq $data->{forwarded}) {
1051 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1052 unless __internal_request();
1056 if (not defined $param{forwarded}) {
1057 $action= "Unset $config{bug} forwarded-to-address";
1059 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1060 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1063 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1065 $data->{forwarded} = $param{forwarded};
1067 append_action_to_log(bug => $data->{bug_num},
1068 command => 'forwarded',
1070 old_data => $old_data,
1072 __return_append_to_log_options(
1077 if not exists $param{append_log} or $param{append_log};
1078 writebug($data->{bug_num},$data);
1079 print {$transcript} "$action\n";
1081 __end_control(%info);
1090 set_title(bug => $ref,
1091 transcript => $transcript,
1092 ($dl > 0 ? (debug => $transcript):()),
1093 requester => $header{from},
1094 request_addr => $controlrequestaddr,
1096 affected_packages => \%affected_packages,
1097 recipients => \%recipients,
1098 title => $new_title,
1103 print {$transcript} "Failed to set the title of $ref: $@";
1106 Sets the title of a specific bug
1112 my %param = validate_with(params => \@_,
1113 spec => {bug => {type => SCALAR,
1116 # specific options here
1117 title => {type => SCALAR,
1120 %append_action_options,
1123 if ($param{title} =~ /[^[:print:]]/) {
1124 die "Non-printable characters are not allowed in bug titles";
1127 my %info = __begin_control(%param,
1130 my ($debug,$transcript) =
1131 @info{qw(debug transcript)};
1132 my @data = @{$info{data}};
1133 my @bugs = @{$info{bugs}};
1135 for my $data (@data) {
1136 my $old_data = dclone($data);
1137 print {$debug} "Going to change bug title\n";
1138 if (defined $data->{subject} and length($data->{subject}) and
1139 $data->{subject} eq $param{title}) {
1140 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1141 unless __internal_request();
1145 if (defined $data->{subject} and length($data->{subject})) {
1146 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1148 $action= "Set $config{bug} title to '$param{title}'.";
1150 $data->{subject} = $param{title};
1152 append_action_to_log(bug => $data->{bug_num},
1155 old_data => $old_data,
1157 __return_append_to_log_options(
1162 if not exists $param{append_log} or $param{append_log};
1163 writebug($data->{bug_num},$data);
1164 print {$transcript} "$action\n";
1166 __end_control(%info);
1173 set_package(bug => $ref,
1174 transcript => $transcript,
1175 ($dl > 0 ? (debug => $transcript):()),
1176 requester => $header{from},
1177 request_addr => $controlrequestaddr,
1179 affected_packages => \%affected_packages,
1180 recipients => \%recipients,
1181 package => $new_package,
1187 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1190 Indicates that a bug is in a particular package. If is_source is true,
1191 indicates that the package is a source package. [Internally, this
1192 causes src: to be prepended to the package name.]
1194 The default for is_source is 0. As a special case, if the package
1195 starts with 'src:', it is assumed to be a source package and is_source
1198 The package option must match the package_name_re regex.
1203 my %param = validate_with(params => \@_,
1204 spec => {bug => {type => SCALAR,
1207 # specific options here
1208 package => {type => SCALAR|ARRAYREF,
1210 is_source => {type => BOOLEAN,
1214 %append_action_options,
1217 my @new_packages = map {splitpackages($_)} make_list($param{package});
1218 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1219 croak "Invalid package name '".
1220 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1223 my %info = __begin_control(%param,
1224 command => 'package',
1226 my ($debug,$transcript) =
1227 @info{qw(debug transcript)};
1228 my @data = @{$info{data}};
1229 my @bugs = @{$info{bugs}};
1230 # clean up the new package
1234 ($temp =~ s/^src:// or
1235 $param{is_source}) ? 'src:'.$temp:$temp;
1239 my $package_reassigned = 0;
1240 for my $data (@data) {
1241 my $old_data = dclone($data);
1242 print {$debug} "Going to change assigned package\n";
1243 if (defined $data->{package} and length($data->{package}) and
1244 $data->{package} eq $new_package) {
1245 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1246 unless __internal_request();
1250 if (defined $data->{package} and length($data->{package})) {
1251 $package_reassigned = 1;
1252 $action= "$config{bug} reassigned from package '$data->{package}'".
1253 " to '$new_package'.";
1255 $action= "$config{bug} assigned to package '$new_package'.";
1257 $data->{package} = $new_package;
1259 append_action_to_log(bug => $data->{bug_num},
1260 command => 'package',
1262 old_data => $old_data,
1264 __return_append_to_log_options(
1269 if not exists $param{append_log} or $param{append_log};
1270 writebug($data->{bug_num},$data);
1271 print {$transcript} "$action\n";
1273 __end_control(%info);
1274 # Only clear the fixed/found versions if the package has been
1276 if ($package_reassigned) {
1277 my @params_for_found_fixed =
1278 map {exists $param{$_}?($_,$param{$_}):()}
1280 keys %common_options,
1281 keys %append_action_options,
1283 set_found(found => [],
1284 @params_for_found_fixed,
1286 set_fixed(fixed => [],
1287 @params_for_found_fixed,
1295 set_found(bug => $ref,
1296 transcript => $transcript,
1297 ($dl > 0 ? (debug => $transcript):()),
1298 requester => $header{from},
1299 request_addr => $controlrequestaddr,
1301 affected_packages => \%affected_packages,
1302 recipients => \%recipients,
1309 print {$transcript} "Failed to set found on $ref: $@";
1313 Sets, adds, or removes the specified found versions of a package
1315 If the version list is empty, and the bug is currently not "done",
1316 causes the done field to be cleared.
1318 If any of the versions added to found are greater than any version in
1319 which the bug is fixed (or when the bug is found and there are no
1320 fixed versions) the done field is cleared.
1325 my %param = validate_with(params => \@_,
1326 spec => {bug => {type => SCALAR,
1329 # specific options here
1330 found => {type => SCALAR|ARRAYREF,
1333 add => {type => BOOLEAN,
1336 remove => {type => BOOLEAN,
1340 %append_action_options,
1343 if ($param{add} and $param{remove}) {
1344 croak "It's nonsensical to add and remove the same versions";
1348 __begin_control(%param,
1351 my ($debug,$transcript) =
1352 @info{qw(debug transcript)};
1353 my @data = @{$info{data}};
1354 my @bugs = @{$info{bugs}};
1356 for my $version (make_list($param{found})) {
1357 next unless defined $version;
1358 $versions{$version} =
1359 [make_source_versions(package => [splitpackages($data[0]{package})],
1360 warnings => $transcript,
1363 versions => $version,
1366 # This is really ugly, but it's what we have to do
1367 if (not @{$versions{$version}}) {
1368 print {$transcript} "Unable to make a source version for version '$version'\n";
1371 if (not keys %versions and ($param{remove} or $param{add})) {
1372 if ($param{remove}) {
1373 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1376 print {$transcript} "Requested to add no versions; doing nothing.\n";
1378 __end_control(%info);
1381 # first things first, make the versions fully qualified source
1383 for my $data (@data) {
1384 # The 'done' field gets a bit weird with version tracking,
1385 # because a bug may be closed by multiple people in different
1386 # branches. Until we have something more flexible, we set it
1387 # every time a bug is fixed, and clear it when a bug is found
1388 # in a version greater than any version in which the bug is
1389 # fixed or when a bug is found and there is no fixed version
1390 my $action = 'Did not alter found versions';
1391 my %found_added = ();
1392 my %found_removed = ();
1393 my %fixed_removed = ();
1395 my $old_data = dclone($data);
1396 if (not $param{add} and not $param{remove}) {
1397 $found_removed{$_} = 1 for @{$data->{found_versions}};
1398 $data->{found_versions} = [];
1401 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1403 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1404 for my $version (keys %versions) {
1406 my @svers = @{$versions{$version}};
1410 for my $sver (@svers) {
1411 if (not exists $found_versions{$sver}) {
1412 $found_versions{$sver} = 1;
1413 $found_added{$sver} = 1;
1415 # if the found we are adding matches any fixed
1416 # versions, remove them
1417 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1418 delete $fixed_versions{$_} for @temp;
1419 $fixed_removed{$_} = 1 for @temp;
1422 # We only care about reopening the bug if the bug is
1424 if (defined $data->{done} and length $data->{done}) {
1425 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1426 map {m{([^/]+)$}; $1;} @svers;
1427 # determine if we need to reopen
1428 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1429 map {m{([^/]+)$}; $1;} keys %fixed_versions;
1430 if (not @fixed_order or
1431 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1437 elsif ($param{remove}) {
1438 # in the case of removal, we only concern ourself with
1439 # the version passed, not the source version it maps
1441 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1442 delete $found_versions{$_} for @temp;
1443 $found_removed{$_} = 1 for @temp;
1446 # set the keys to exactly these values
1447 my @svers = @{$versions{$version}};
1451 for my $sver (@svers) {
1452 if (not exists $found_versions{$sver}) {
1453 $found_versions{$sver} = 1;
1454 if (exists $found_removed{$sver}) {
1455 delete $found_removed{$sver};
1458 $found_added{$sver} = 1;
1465 $data->{found_versions} = [keys %found_versions];
1466 $data->{fixed_versions} = [keys %fixed_versions];
1469 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1470 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1471 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1472 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1473 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1475 $action .= " and reopened"
1477 if (not $reopened and not @changed) {
1478 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1479 unless __internal_request();
1483 append_action_to_log(bug => $data->{bug_num},
1486 old_data => $old_data,
1488 __return_append_to_log_options(
1493 if not exists $param{append_log} or $param{append_log};
1494 writebug($data->{bug_num},$data);
1495 print {$transcript} "$action\n";
1497 __end_control(%info);
1503 set_fixed(bug => $ref,
1504 transcript => $transcript,
1505 ($dl > 0 ? (debug => $transcript):()),
1506 requester => $header{from},
1507 request_addr => $controlrequestaddr,
1509 affected_packages => \%affected_packages,
1510 recipients => \%recipients,
1518 print {$transcript} "Failed to set fixed on $ref: $@";
1522 Sets, adds, or removes the specified fixed versions of a package
1524 If the fixed versions are empty (or end up being empty after this
1525 call) or the greatest fixed version is less than the greatest found
1526 version and the reopen option is true, the bug is reopened.
1528 This function is also called by the reopen function, which causes all
1529 of the fixed versions to be cleared.
1534 my %param = validate_with(params => \@_,
1535 spec => {bug => {type => SCALAR,
1538 # specific options here
1539 fixed => {type => SCALAR|ARRAYREF,
1542 add => {type => BOOLEAN,
1545 remove => {type => BOOLEAN,
1548 reopen => {type => BOOLEAN,
1552 %append_action_options,
1555 if ($param{add} and $param{remove}) {
1556 croak "It's nonsensical to add and remove the same versions";
1559 __begin_control(%param,
1562 my ($debug,$transcript) =
1563 @info{qw(debug transcript)};
1564 my @data = @{$info{data}};
1565 my @bugs = @{$info{bugs}};
1567 for my $version (make_list($param{fixed})) {
1568 next unless defined $version;
1569 $versions{$version} =
1570 [make_source_versions(package => [splitpackages($data[0]{package})],
1571 warnings => $transcript,
1574 versions => $version,
1577 # This is really ugly, but it's what we have to do
1578 if (not @{$versions{$version}}) {
1579 print {$transcript} "Unable to make a source version for version '$version'\n";
1582 if (not keys %versions and ($param{remove} or $param{add})) {
1583 if ($param{remove}) {
1584 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1587 print {$transcript} "Requested to add no versions; doing nothing.\n";
1589 __end_control(%info);
1592 # first things first, make the versions fully qualified source
1594 for my $data (@data) {
1595 my $old_data = dclone($data);
1596 # The 'done' field gets a bit weird with version tracking,
1597 # because a bug may be closed by multiple people in different
1598 # branches. Until we have something more flexible, we set it
1599 # every time a bug is fixed, and clear it when a bug is found
1600 # in a version greater than any version in which the bug is
1601 # fixed or when a bug is found and there is no fixed version
1602 my $action = 'Did not alter fixed versions';
1603 my %found_added = ();
1604 my %found_removed = ();
1605 my %fixed_added = ();
1606 my %fixed_removed = ();
1608 if (not $param{add} and not $param{remove}) {
1609 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1610 $data->{fixed_versions} = [];
1613 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1615 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1616 for my $version (keys %versions) {
1618 my @svers = @{$versions{$version}};
1622 for my $sver (@svers) {
1623 if (not exists $fixed_versions{$sver}) {
1624 $fixed_versions{$sver} = 1;
1625 $fixed_added{$sver} = 1;
1629 elsif ($param{remove}) {
1630 # in the case of removal, we only concern ourself with
1631 # the version passed, not the source version it maps
1633 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1634 delete $fixed_versions{$_} for @temp;
1635 $fixed_removed{$_} = 1 for @temp;
1638 # set the keys to exactly these values
1639 my @svers = @{$versions{$version}};
1643 for my $sver (@svers) {
1644 if (not exists $fixed_versions{$sver}) {
1645 $fixed_versions{$sver} = 1;
1646 if (exists $fixed_removed{$sver}) {
1647 delete $fixed_removed{$sver};
1650 $fixed_added{$sver} = 1;
1657 $data->{found_versions} = [keys %found_versions];
1658 $data->{fixed_versions} = [keys %fixed_versions];
1660 # If we're supposed to consider reopening, reopen if the
1661 # fixed versions are empty or the greatest found version
1662 # is greater than the greatest fixed version
1663 if ($param{reopen} and defined $data->{done}
1664 and length $data->{done}) {
1665 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1666 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1667 # determine if we need to reopen
1668 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1669 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1670 if (not @fixed_order or
1671 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1678 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1679 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1680 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1681 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1682 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1684 $action .= " and reopened"
1686 if (not $reopened and not @changed) {
1687 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1688 unless __internal_request();
1692 append_action_to_log(bug => $data->{bug_num},
1695 old_data => $old_data,
1697 __return_append_to_log_options(
1702 if not exists $param{append_log} or $param{append_log};
1703 writebug($data->{bug_num},$data);
1704 print {$transcript} "$action\n";
1706 __end_control(%info);
1714 affects(bug => $ref,
1715 transcript => $transcript,
1716 ($dl > 0 ? (debug => $transcript):()),
1717 requester => $header{from},
1718 request_addr => $controlrequestaddr,
1720 affected_packages => \%affected_packages,
1721 recipients => \%recipients,
1729 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
1732 This marks a bug as affecting packages which the bug is not actually
1733 in. This should only be used in cases where fixing the bug instantly
1734 resolves the problem in the other packages.
1736 By default, the packages are set to the list of packages passed.
1737 However, if you pass add => 1 or remove => 1, the list of packages
1738 passed are added or removed from the affects list, respectively.
1743 my %param = validate_with(params => \@_,
1744 spec => {bug => {type => SCALAR,
1747 # specific options here
1748 packages => {type => SCALAR|ARRAYREF,
1751 add => {type => BOOLEAN,
1754 remove => {type => BOOLEAN,
1758 %append_action_options,
1761 if ($param{add} and $param{remove}) {
1762 croak "Asking to both add and remove affects is nonsensical";
1765 __begin_control(%param,
1766 command => 'affects'
1768 my ($debug,$transcript) =
1769 @info{qw(debug transcript)};
1770 my @data = @{$info{data}};
1771 my @bugs = @{$info{bugs}};
1773 for my $data (@data) {
1775 print {$debug} "Going to change affects\n";
1776 my @packages = splitpackages($data->{affects});
1778 @packages{@packages} = (1) x @packages;
1781 for my $package (make_list($param{packages})) {
1782 next unless defined $package and length $package;
1783 if (not $packages{$package}) {
1784 $packages{$package} = 1;
1785 push @added,$package;
1789 $action = "Added indication that $data->{bug_num} affects ".
1790 english_join(\@added);
1793 elsif ($param{remove}) {
1795 for my $package (make_list($param{packages})) {
1796 if ($packages{$package}) {
1797 next unless defined $package and length $package;
1798 delete $packages{$package};
1799 push @removed,$package;
1802 $action = "Removed indication that $data->{bug_num} affects " .
1803 english_join(\@removed);
1806 my %added_packages = ();
1807 my %removed_packages = %packages;
1809 for my $package (make_list($param{packages})) {
1810 next unless defined $package and length $package;
1811 $packages{$package} = 1;
1812 delete $removed_packages{$package};
1813 $added_packages{$package} = 1;
1815 if (keys %removed_packages) {
1816 $action = "Removed indication that $data->{bug_num} affects ".
1817 english_join([keys %removed_packages]);
1818 $action .= "\n" if keys %added_packages;
1820 if (keys %added_packages) {
1821 $action .= "Added indication that $data->{bug_num} affects " .
1822 english_join([keys %added_packages]);
1825 if (not length $action) {
1826 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
1827 unless __internal_request();
1829 my $old_data = dclone($data);
1830 $data->{affects} = join(',',keys %packages);
1831 append_action_to_log(bug => $data->{bug_num},
1833 command => 'affects',
1835 old_data => $old_data,
1836 __return_append_to_log_options(
1841 if not exists $param{append_log} or $param{append_log};
1842 writebug($data->{bug_num},$data);
1843 print {$transcript} "$action\n";
1845 __end_control(%info);
1849 =head1 SUMMARY FUNCTIONS
1854 summary(bug => $ref,
1855 transcript => $transcript,
1856 ($dl > 0 ? (debug => $transcript):()),
1857 requester => $header{from},
1858 request_addr => $controlrequestaddr,
1860 affected_packages => \%affected_packages,
1861 recipients => \%recipients,
1867 print {$transcript} "Failed to mark $ref with summary foo: $@";
1870 Handles all setting of summary fields
1872 If summary is undef, unsets the summary
1874 If summary is 0, sets the summary to the first paragraph contained in
1877 If summary is numeric, sets the summary to the message specified.
1884 my %param = validate_with(params => \@_,
1885 spec => {bug => {type => SCALAR,
1888 # specific options here
1889 summary => {type => SCALAR|UNDEF,
1893 %append_action_options,
1896 croak "summary must be numeric or undef" if
1897 defined $param{summary} and not $param{summary} =~ /^\d+$/;
1899 __begin_control(%param,
1900 command => 'summary'
1902 my ($debug,$transcript) =
1903 @info{qw(debug transcript)};
1904 my @data = @{$info{data}};
1905 my @bugs = @{$info{bugs}};
1906 # figure out the log that we're going to use
1908 my $summary_msg = '';
1910 if (not defined $param{summary}) {
1912 print {$debug} "Removing summary fields\n";
1913 $action = 'Removed summary';
1917 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
1918 if ($param{summary} == 0) {
1919 $log = $param{message};
1920 $summary_msg = @records + 1;
1923 if (($param{summary} - 1 ) > $#records) {
1924 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
1926 my $record = $records[($param{summary} - 1 )];
1927 if ($record->{type} !~ /incoming-recv|recips/) {
1928 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
1930 $summary_msg = $param{summary};
1931 $log = [$record->{text}];
1933 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
1934 my $body = $p_o->{body};
1935 my $in_pseudoheaders = 0;
1937 # walk through body until we get non-blank lines
1938 for my $line (@{$body}) {
1939 if ($line =~ /^\s*$/) {
1940 if (length $paragraph) {
1941 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
1947 $in_pseudoheaders = 0;
1950 # skip a paragraph if it looks like it's control or
1952 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
1953 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
1954 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
1955 debug|(?:not|)forwarded|priority|
1956 (?:un|)block|limit|(?:un|)archive|
1957 reassign|retitle|affects|wrongpackage
1958 (?:un|force|)merge|user(?:category|tags?|)
1960 if (not length $paragraph) {
1961 print {$debug} "Found control/pseudo-headers and skiping them\n";
1962 $in_pseudoheaders = 1;
1966 next if $in_pseudoheaders;
1967 $paragraph .= $line ." \n";
1969 print {$debug} "Summary is going to be '$paragraph'\n";
1970 $summary = $paragraph;
1971 $summary =~ s/[\n\r]/ /g;
1972 if (not length $summary) {
1973 die "Unable to find summary message to use";
1975 # trim off a trailing spaces
1976 $summary =~ s/\ *$//;
1978 for my $data (@data) {
1979 print {$debug} "Going to change summary\n";
1980 if (((not defined $summary or not length $summary) and
1981 (not defined $data->{summary} or not length $data->{summary})) or
1982 $summary eq $data->{summary}) {
1983 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1984 unless __internal_request();
1987 if (length $summary) {
1988 if (length $data->{summary}) {
1989 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1992 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1995 my $old_data = dclone($data);
1996 $data->{summary} = $summary;
1997 append_action_to_log(bug => $data->{bug_num},
1998 command => 'summary',
1999 old_data => $old_data,
2002 __return_append_to_log_options(
2007 if not exists $param{append_log} or $param{append_log};
2008 writebug($data->{bug_num},$data);
2009 print {$transcript} "$action\n";
2011 __end_control(%info);
2017 =head1 OWNER FUNCTIONS
2023 transcript => $transcript,
2024 ($dl > 0 ? (debug => $transcript):()),
2025 requester => $header{from},
2026 request_addr => $controlrequestaddr,
2028 recipients => \%recipients,
2034 print {$transcript} "Failed to mark $ref as having an owner: $@";
2037 Handles all setting of the owner field; given an owner of undef or of
2038 no length, indicates that a bug is not owned by anyone.
2043 my %param = validate_with(params => \@_,
2044 spec => {bug => {type => SCALAR,
2047 owner => {type => SCALAR|UNDEF,
2050 %append_action_options,
2054 __begin_control(%param,
2057 my ($debug,$transcript) =
2058 @info{qw(debug transcript)};
2059 my @data = @{$info{data}};
2060 my @bugs = @{$info{bugs}};
2062 for my $data (@data) {
2063 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2064 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2065 if (not defined $param{owner} or not length $param{owner}) {
2066 if (not defined $data->{owner} or not length $data->{owner}) {
2067 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2068 unless __internal_request();
2072 $action = "Removed annotation that $config{bug} was owned by " .
2076 if ($data->{owner} eq $param{owner}) {
2077 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2080 if (length $data->{owner}) {
2081 $action = "Owner changed from $data->{owner} to $param{owner}.";
2084 $action = "Owner recorded as $param{owner}."
2087 my $old_data = dclone($data);
2088 $data->{owner} = $param{owner};
2089 append_action_to_log(bug => $data->{bug_num},
2092 old_data => $old_data,
2094 __return_append_to_log_options(
2099 if not exists $param{append_log} or $param{append_log};
2100 writebug($data->{bug_num},$data);
2101 print {$transcript} "$action\n";
2103 __end_control(%info);
2107 =head1 ARCHIVE FUNCTIONS
2114 bug_archive(bug => $bug_num,
2116 transcript => \$transcript,
2121 transcript("Unable to archive $bug_num\n");
2124 transcript($transcript);
2127 This routine archives a bug
2131 =item bug -- bug number
2133 =item check_archiveable -- check wether a bug is archiveable before
2134 archiving; defaults to 1
2136 =item archive_unarchived -- whether to archive bugs which have not
2137 previously been archived; defaults to 1. [Set to 0 when used from
2140 =item ignore_time -- whether to ignore time constraints when archiving
2141 a bug; defaults to 0.
2148 my %param = validate_with(params => \@_,
2149 spec => {bug => {type => SCALAR,
2152 check_archiveable => {type => BOOLEAN,
2155 archive_unarchived => {type => BOOLEAN,
2158 ignore_time => {type => BOOLEAN,
2162 %append_action_options,
2165 my %info = __begin_control(%param,
2166 command => 'archive',
2168 my ($debug,$transcript) = @info{qw(debug transcript)};
2169 my @data = @{$info{data}};
2170 my @bugs = @{$info{bugs}};
2171 my $action = "$config{bug} archived.";
2172 if ($param{check_archiveable} and
2173 not bug_archiveable(bug=>$param{bug},
2174 ignore_time => $param{ignore_time},
2176 print {$transcript} "Bug $param{bug} cannot be archived\n";
2177 die "Bug $param{bug} cannot be archived";
2179 print {$debug} "$param{bug} considering\n";
2180 if (not $param{archive_unarchived} and
2181 not exists $data[0]{unarchived}
2183 print {$transcript} "$param{bug} has not been archived previously\n";
2184 die "$param{bug} has not been archived previously";
2186 add_recipients(recipients => $param{recipients},
2189 transcript => $transcript,
2191 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2192 for my $bug (@bugs) {
2193 if ($param{check_archiveable}) {
2194 die "Bug $bug cannot be archived (but $param{bug} can?)"
2195 unless bug_archiveable(bug=>$bug,
2196 ignore_time => $param{ignore_time},
2200 # If we get here, we can archive/remove this bug
2201 print {$debug} "$param{bug} removing\n";
2202 for my $bug (@bugs) {
2203 #print "$param{bug} removing $bug\n" if $debug;
2204 my $dir = get_hashname($bug);
2205 # First indicate that this bug is being archived
2206 append_action_to_log(bug => $bug,
2208 command => 'archive',
2209 # we didn't actually change the data
2210 # when we archived, so we don't pass
2211 # a real new_data or old_data
2214 __return_append_to_log_options(
2219 if not exists $param{append_log} or $param{append_log};
2220 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2221 if ($config{save_old_bugs}) {
2222 mkpath("$config{spool_dir}/archive/$dir");
2223 foreach my $file (@files_to_remove) {
2224 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2225 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2226 # we need to bail out here if things have
2227 # gone horribly wrong to avoid removing a
2229 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2232 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2234 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2235 print {$transcript} "deleted $bug (from $param{bug})\n";
2237 bughook_archive(@bugs);
2238 __end_control(%info);
2241 =head2 bug_unarchive
2245 bug_unarchive(bug => $bug_num,
2247 transcript => \$transcript,
2252 transcript("Unable to archive bug: $bug_num");
2254 transcript($transcript);
2256 This routine unarchives a bug
2261 my %param = validate_with(params => \@_,
2262 spec => {bug => {type => SCALAR,
2266 %append_action_options,
2270 my %info = __begin_control(%param,
2272 command=>'unarchive');
2273 my ($debug,$transcript) =
2274 @info{qw(debug transcript)};
2275 my @data = @{$info{data}};
2276 my @bugs = @{$info{bugs}};
2277 my $action = "$config{bug} unarchived.";
2278 my @files_to_remove;
2279 for my $bug (@bugs) {
2280 print {$debug} "$param{bug} removing $bug\n";
2281 my $dir = get_hashname($bug);
2282 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
2283 mkpath("archive/$dir");
2284 foreach my $file (@files_to_copy) {
2285 # die'ing here sucks
2286 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2287 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2288 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
2290 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
2291 print {$transcript} "Unarchived $config{bug} $bug\n";
2293 unlink(@files_to_remove) or die "Unable to unlink bugs";
2294 # Indicate that this bug has been archived previously
2295 for my $bug (@bugs) {
2296 my $newdata = readbug($bug);
2297 my $old_data = dclone($newdata);
2298 if (not defined $newdata) {
2299 print {$transcript} "$config{bug} $bug disappeared!\n";
2300 die "Bug $bug disappeared!";
2302 $newdata->{unarchived} = time;
2303 append_action_to_log(bug => $bug,
2305 command => 'unarchive',
2306 new_data => $newdata,
2307 old_data => $old_data,
2308 __return_append_to_log_options(
2313 if not exists $param{append_log} or $param{append_log};
2314 writebug($bug,$newdata);
2316 __end_control(%info);
2319 =head2 append_action_to_log
2321 append_action_to_log
2323 This should probably be moved to Debbugs::Log; have to think that out
2328 sub append_action_to_log{
2329 my %param = validate_with(params => \@_,
2330 spec => {bug => {type => SCALAR,
2333 new_data => {type => HASHREF,
2336 old_data => {type => HASHREF,
2339 command => {type => SCALAR,
2342 action => {type => SCALAR,
2344 requester => {type => SCALAR,
2347 request_addr => {type => SCALAR,
2350 location => {type => SCALAR,
2353 message => {type => SCALAR|ARRAYREF,
2356 desc => {type => SCALAR,
2359 get_lock => {type => BOOLEAN,
2363 # append_action_options here
2364 # because some of these
2365 # options aren't actually
2366 # optional, even though the
2367 # original function doesn't
2371 # Fix this to use $param{location}
2372 my $log_location = buglog($param{bug});
2373 die "Unable to find .log for $param{bug}"
2374 if not defined $log_location;
2375 if ($param{get_lock}) {
2376 filelock("lock/$param{bug}");
2378 my $log = IO::File->new(">>$log_location") or
2379 die "Unable to open $log_location for appending: $!";
2380 # determine difference between old and new
2382 if (exists $param{old_data} and exists $param{new_data}) {
2383 my $old_data = dclone($param{old_data});
2384 my $new_data = dclone($param{new_data});
2385 for my $key (keys %{$old_data}) {
2386 if (not exists $Debbugs::Status::fields{$key}) {
2387 delete $old_data->{$key};
2390 next unless exists $new_data->{$key};
2391 next unless defined $new_data->{$key};
2392 if (not defined $old_data->{$key}) {
2393 delete $old_data->{$key};
2396 if (ref($new_data->{$key}) and
2397 ref($old_data->{$key}) and
2398 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2399 local $Storable::canonical = 1;
2400 # print STDERR Dumper($new_data,$old_data,$key);
2401 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2402 delete $new_data->{$key};
2403 delete $old_data->{$key};
2406 elsif ($new_data->{$key} eq $old_data->{$key}) {
2407 delete $new_data->{$key};
2408 delete $old_data->{$key};
2411 for my $key (keys %{$new_data}) {
2412 if (not exists $Debbugs::Status::fields{$key}) {
2413 delete $new_data->{$key};
2416 next unless exists $old_data->{$key};
2417 next unless defined $old_data->{$key};
2418 if (not defined $new_data->{$key} or
2419 not exists $Debbugs::Status::fields{$key}) {
2420 delete $new_data->{$key};
2423 if (ref($new_data->{$key}) and
2424 ref($old_data->{$key}) and
2425 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2426 local $Storable::canonical = 1;
2427 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2428 delete $new_data->{$key};
2429 delete $old_data->{$key};
2432 elsif ($new_data->{$key} eq $old_data->{$key}) {
2433 delete $new_data->{$key};
2434 delete $old_data->{$key};
2437 $data_diff .= "<!-- new_data:\n";
2439 for my $key (keys %{$new_data}) {
2440 if (not exists $Debbugs::Status::fields{$key}) {
2441 warn "No such field $key";
2444 $nd{$key} = $new_data->{$key};
2445 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
2447 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
2448 $data_diff .= "-->\n";
2449 $data_diff .= "<!-- old_data:\n";
2451 for my $key (keys %{$old_data}) {
2452 if (not exists $Debbugs::Status::fields{$key}) {
2453 warn "No such field $key";
2456 $od{$key} = $old_data->{$key};
2457 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
2459 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
2460 $data_diff .= "-->\n";
2462 my $msg = join('',"\6\n",
2463 (exists $param{command} ?
2464 "<!-- command:".html_escape($param{command})." -->\n":""
2466 (length $param{requester} ?
2467 "<!-- requester: ".html_escape($param{requester})." -->\n":""
2469 (length $param{request_addr} ?
2470 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
2472 "<!-- time:".time()." -->\n",
2474 "<strong>".html_escape($param{action})."</strong>\n");
2475 if (length $param{requester}) {
2476 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
2478 if (length $param{request_addr}) {
2479 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
2481 if (length $param{desc}) {
2482 $msg .= ":<br>\n$param{desc}\n";
2488 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
2489 $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
2490 or die "Unable to append to $log_location: $!";
2492 print {$log} $msg or die "Unable to append to $log_location: $!";
2493 close $log or die "Unable to close $log_location: $!";
2494 if ($param{get_lock}) {
2502 =head1 PRIVATE FUNCTIONS
2504 =head2 __handle_affected_packages
2506 __handle_affected_packages(affected_packages => {},
2514 sub __handle_affected_packages{
2515 my %param = validate_with(params => \@_,
2516 spec => {%common_options,
2517 data => {type => ARRAYREF|HASHREF
2522 for my $data (make_list($param{data})) {
2523 next unless exists $data->{package} and defined $data->{package};
2524 my @packages = split /\s*,\s*/,$data->{package};
2525 @{$param{affected_packages}}{@packages} = (1) x @packages;
2529 =head2 __handle_debug_transcript
2531 my ($debug,$transcript) = __handle_debug_transcript(%param);
2533 Returns a debug and transcript filehandle
2538 sub __handle_debug_transcript{
2539 my %param = validate_with(params => \@_,
2540 spec => {%common_options},
2543 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
2544 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
2545 return ($debug,$transcript);
2552 Produces a small bit of bug information to kick out to the transcript
2559 next unless defined $data and exists $data->{bug_num};
2560 $return .= "Bug #".($data->{bug_num}||'').
2561 ((defined $data->{done} and length $data->{done})?
2562 " {Done: $data->{done}}":''
2564 " [".($data->{package}||'(no package)'). "] ".
2565 ($data->{subject}||'(no subject)')."\n";
2571 =head2 __internal_request
2573 __internal_request()
2574 __internal_request($level)
2576 Returns true if the caller of the function calling __internal_request
2577 belongs to __PACKAGE__
2579 This allows us to be magical, and don't bother to print bug info if
2580 the second caller is from this package, amongst other things.
2582 An optional level is allowed, which increments the number of levels to
2583 check by the given value. [This is basically for use by internal
2584 functions like __begin_control which are always called by
2589 sub __internal_request{
2591 $l = 0 if not defined $l;
2592 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
2598 sub __return_append_to_log_options{
2600 my $action = $param{action} if exists $param{action};
2601 if (not exists $param{requester}) {
2602 $param{requester} = $config{control_internal_requester};
2604 if (not exists $param{request_addr}) {
2605 $param{request_addr} = $config{control_internal_request_addr};
2607 if (not exists $param{message}) {
2608 my $date = rfc822_date();
2609 $param{message} = fill_in_template(template => 'mail/fake_control_message',
2610 variables => {request_addr => $param{request_addr},
2611 requester => $param{requester},
2617 if (not defined $action) {
2618 carp "Undefined action!";
2619 $action = "unknown action";
2621 return (action => $action,
2622 (map {exists $append_action_options{$_}?($_,$param{$_}):()}
2627 =head2 __begin_control
2629 my %info = __begin_control(%param,
2631 command=>'unarchive');
2632 my ($debug,$transcript) = @info{qw(debug transcript)};
2633 my @data = @{$info{data}};
2634 my @bugs = @{$info{bugs}};
2637 Starts the process of modifying a bug; handles all of the generic
2638 things that almost every control request needs
2640 Returns a hash containing
2644 =item new_locks -- number of new locks taken out by this call
2646 =item debug -- the debug file handle
2648 =item transcript -- the transcript file handle
2650 =item data -- an arrayref containing the data of the bugs
2651 corresponding to this request
2653 =item bugs -- an arrayref containing the bug numbers of the bugs
2654 corresponding to this request
2662 sub __begin_control {
2663 my %param = validate_with(params => \@_,
2664 spec => {bug => {type => SCALAR,
2667 archived => {type => BOOLEAN,
2670 command => {type => SCALAR,
2678 my ($debug,$transcript) = __handle_debug_transcript(@_);
2679 print {$debug} "$param{bug} considering\n";
2681 my $old_die = $SIG{__DIE__};
2682 $SIG{__DIE__} = *sig_die{CODE};
2684 ($new_locks, @data) =
2685 lock_read_all_merged_bugs($param{bug},
2686 ($param{archived}?'archive':()));
2687 $locks += $new_locks;
2689 die "Unable to read any bugs successfully.";
2691 if (not $param{archived}) {
2692 for my $data (@data) {
2693 if ($data->{archived}) {
2694 die "Not altering archived bugs; see unarchive.";
2698 if (not __check_limit(data => \@data,
2699 exists $param{limit}?(limit => $param{limit}):(),
2701 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2704 __handle_affected_packages(%param,data => \@data);
2705 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2706 print {$debug} "$param{bug} read $locks locks\n";
2707 if (not @data or not defined $data[0]) {
2708 print {$transcript} "No bug found for $param{bug}\n";
2709 die "No bug found for $param{bug}";
2712 add_recipients(data => \@data,
2713 recipients => $param{recipients},
2714 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2716 (__internal_request()?(transcript => $transcript):()),
2719 print {$debug} "$param{bug} read done\n";
2720 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2721 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2722 return (data => \@data,
2724 old_die => $old_die,
2725 new_locks => $new_locks,
2727 transcript => $transcript,
2732 =head2 __end_control
2734 __end_control(%info);
2736 Handles tearing down from a control request
2742 if (exists $info{new_locks} and $info{new_locks} > 0) {
2743 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2744 for (1..$info{new_locks}) {
2748 $SIG{__DIE__} = $info{old_die};
2749 if (exists $info{param}{bugs_affected}) {
2750 @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2752 add_recipients(recipients => $info{param}{recipients},
2753 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
2754 data => $info{data},
2755 debug => $info{debug},
2756 transcript => $info{transcript},
2758 __handle_affected_packages(%{$info{param}},data=>$info{data});
2762 =head2 __check_limit
2764 __check_limit(data => \@data, limit => $param{limit});
2767 Checks to make sure that bugs match any limits; each entry of @data
2768 much satisfy the limit.
2770 Returns true if there are no entries in data, or there are no keys in
2771 limit; returns false (0) if there are any entries which do not match.
2773 The limit hashref elements can contain an arrayref of scalars to
2774 match; regexes are also acccepted. At least one of the entries in each
2775 element needs to match the corresponding field in all data for the
2782 my %param = validate_with(params => \@_,
2783 spec => {data => {type => ARRAYREF|SCALAR,
2785 limit => {type => HASHREF|UNDEF,
2789 my @data = make_list($param{data});
2791 not defined $param{limit} or
2792 not keys %{$param{limit}}) {
2795 for my $data (@data) {
2796 for my $field (keys %{$param{limit}}) {
2797 next unless exists $param{limit}{$field};
2799 for my $limit (make_list($param{limit}{$field})) {
2800 if (not ref $limit) {
2801 if ($data->{$field} eq $limit) {
2806 elsif (ref($limit) eq 'Regexp') {
2807 if ($data->{$field} =~ $limit) {
2813 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
2829 We override die to specially handle unlocking files in the cases where
2830 we are called via eval. [If we're not called via eval, it doesn't
2836 #if ($^S) { # in eval
2838 for (1..$locks) { unfilelock(); }
2845 # =head2 __message_body_template
2847 # message_body_template('mail/ack',{ref=>'foo'});
2849 # Creates a message body using a template
2853 sub __message_body_template{
2854 my ($template,$extra_var) = @_;
2856 my $hole_var = {'&bugurl' =>
2858 'http://'.$config{cgi_domain}.'/'.
2859 Debbugs::CGI::bug_url($_[0]);
2863 my $body = fill_in_template(template => $template,
2864 variables => {config => \%config,
2867 hole_var => $hole_var,
2869 return fill_in_template(template => 'mail/message_body',
2870 variables => {config => \%config,
2874 hole_var => $hole_var,