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}));
322 if (exists $param{add}) {
325 elsif (exists $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 tags of bug #$data->{bug_num} to the same tags 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,
513 __handle_affected_packages(%param,data=>\@blocking_data);
514 add_recipients(recipients => $param{recipients},
515 actions_taken => {blocks => 1},
516 data => \@blocking_data,
518 transcript => $transcript,
521 unfilelock() for $new_locks;
524 __end_control(%info);
533 transcript => $transcript,
534 ($dl > 0 ? (debug => $transcript):()),
535 requester => $header{from},
536 request_addr => $controlrequestaddr,
538 affected_packages => \%affected_packages,
539 recipients => \%recipients,
546 print {$transcript} "Failed to set tag on $ref: $@";
550 Sets, adds, or removes the specified tags on a bug
554 =item tag -- scalar or arrayref of tags to set, add or remove
556 =item add -- if true, add tags
558 =item remove -- if true, remove tags
560 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
568 my %param = validate_with(params => \@_,
569 spec => {bug => {type => SCALAR,
572 # specific options here
573 tag => {type => SCALAR|ARRAYREF,
576 add => {type => BOOLEAN,
579 remove => {type => BOOLEAN,
582 warn_on_bad_tags => {type => BOOLEAN,
586 %append_action_options,
589 if ($param{add} and $param{remove}) {
590 croak "It's nonsensical to add and remove the same tags";
594 __begin_control(%param,
597 my ($debug,$transcript) =
598 @info{qw(debug transcript)};
599 my @data = @{$info{data}};
600 my @bugs = @{$info{bugs}};
601 my @tags = make_list($param{tag});
602 if (not @tags and ($param{remove} or $param{add})) {
603 if ($param{remove}) {
604 print {$transcript} "Requested to remove no tags; doing nothing.\n";
607 print {$transcript} "Requested to add no tags; doing nothing.\n";
609 __end_control(%info);
612 # first things first, make the versions fully qualified source
614 for my $data (@data) {
615 my $action = 'Did not alter tags';
617 my %tag_removed = ();
618 my %fixed_removed = ();
619 my @old_tags = split /\,\s*/, $data->{keywords};
621 @tags{@old_tags} = (1) x @old_tags;
623 my $old_data = dclone($data);
624 if (not $param{add} and not $param{remove}) {
625 $tag_removed{$_} = 1 for @old_tags;
629 for my $tag (@tags) {
630 if (not $param{remove} and
631 not defined first {$_ eq $tag} @{$config{tags}}) {
632 push @bad_tags, $tag;
636 if (not exists $tags{$tag}) {
638 $tag_added{$tag} = 1;
641 elsif ($param{remove}) {
642 if (exists $tags{$tag}) {
644 $tag_removed{$tag} = 1;
648 if (exists $tag_removed{$tag}) {
649 delete $tag_removed{$tag};
652 $tag_added{$tag} = 1;
657 if (@bad_tags and $param{warn_on_bad_tags}) {
658 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
659 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
661 $data->{keywords} = join(', ',keys %tags); # double check this
664 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
665 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
666 $action = ucfirst(join ('; ',@changed)) if @changed;
668 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
669 unless __internal_request();
673 append_action_to_log(bug => $data->{bug_num},
676 old_data => $old_data,
678 __return_append_to_log_options(
683 if not exists $param{append_log} or $param{append_log};
684 writebug($data->{bug_num},$data);
685 print {$transcript} "$action\n";
687 __end_control(%info);
695 set_severity(bug => $ref,
696 transcript => $transcript,
697 ($dl > 0 ? (debug => $transcript):()),
698 requester => $header{from},
699 request_addr => $controlrequestaddr,
701 affected_packages => \%affected_packages,
702 recipients => \%recipients,
703 severity => 'normal',
708 print {$transcript} "Failed to set the severity of bug $ref: $@";
711 Sets the severity of a bug. If severity is not passed, is undefined,
712 or has zero length, sets the severity to the defafult severity.
717 my %param = validate_with(params => \@_,
718 spec => {bug => {type => SCALAR,
721 # specific options here
722 severity => {type => SCALAR|UNDEF,
723 default => $config{default_severity},
726 %append_action_options,
729 if (not defined $param{severity} or
730 not length $param{severity}
732 $param{severity} = $config{default_severity};
735 # check validity of new severity
736 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
737 die "Severity '$param{severity}' is not a valid severity level";
740 __begin_control(%param,
741 command => 'severity'
743 my ($debug,$transcript) =
744 @info{qw(debug transcript)};
745 my @data = @{$info{data}};
746 my @bugs = @{$info{bugs}};
749 for my $data (@data) {
750 if (not defined $data->{severity}) {
751 $data->{severity} = $param{severity};
752 $action = "Severity set to '$param{severity}'\n";
755 if ($data->{severity} eq '') {
756 $data->{severity} = $config{default_severity};
758 if ($data->{severity} eq $param{severity}) {
759 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
762 $action = "Severity set to '$param{severity}' from '$data->{severity}'\n";
763 $data->{severity} = $param{severity};
765 append_action_to_log(bug => $data->{bug_num},
767 __return_append_to_log_options(
772 if not exists $param{append_log} or $param{append_log};
773 writebug($data->{bug_num},$data);
774 print {$transcript} "$action\n";
776 __end_control(%info);
784 transcript => $transcript,
785 ($dl > 0 ? (debug => $transcript):()),
786 requester => $header{from},
787 request_addr => $controlrequestaddr,
789 affected_packages => \%affected_packages,
790 recipients => \%recipients,
796 print {$transcript} "Failed to set foo $ref bar: $@";
804 my %param = validate_with(params => \@_,
805 spec => {bug => {type => SCALAR,
808 # specific options here
809 submitter => {type => SCALAR|UNDEF,
813 %append_action_options,
817 $param{submitter} = undef if defined $param{submitter} and
818 not length $param{submitter};
820 if (defined $param{submitter} and
821 not Mail::RFC822::Address::valid($param{submitter})) {
822 die "New submitter address $param{submitter} is not a valid e-mail address";
826 __begin_control(%param,
829 my ($debug,$transcript) =
830 @info{qw(debug transcript)};
831 my @data = @{$info{data}};
832 my @bugs = @{$info{bugs}};
835 my $warn_fixed = 1; # avoid warning multiple times if there are
837 my @change_submitter = ();
838 my @bugs_to_reopen = ();
839 for my $data (@data) {
840 if (not exists $data->{done} or
841 not defined $data->{done} or
842 not length $data->{done}) {
843 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
844 __end_control(%info);
847 if (@{$data->{fixed_versions}} and $warn_fixed) {
848 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
849 print {$transcript} "you may need to use 'found' to remove fixed versions.\n";
852 if (defined $param{submitter} and length $param{submitter}
853 and $data->{originator} ne $param{submitter}) {
854 push @change_submitter,$data->{bug_num};
857 __end_control(%info);
858 my @params_for_subcalls =
859 map {exists $param{$_}?($_,$param{$_}):()}
860 (keys %common_options,
861 keys %append_action_options,
864 for my $bug (@change_submitter) {
865 set_submitter(bug=>$bug,
866 submitter => $param{submitter},
867 @params_for_subcalls,
870 set_fixed(fixed => [],
880 set_submitter(bug => $ref,
881 transcript => $transcript,
882 ($dl > 0 ? (debug => $transcript):()),
883 requester => $header{from},
884 request_addr => $controlrequestaddr,
886 affected_packages => \%affected_packages,
887 recipients => \%recipients,
888 submitter => $new_submitter,
889 notify_submitter => 1,
894 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
897 Sets the submitter of a bug. If notify_submitter is true (the
898 default), notifies the old submitter of a bug on changes
903 my %param = validate_with(params => \@_,
904 spec => {bug => {type => SCALAR,
907 # specific options here
908 submitter => {type => SCALAR,
910 notify_submitter => {type => BOOLEAN,
914 %append_action_options,
917 if (not Mail::RFC822::Address::valid($param{submitter})) {
918 die "New submitter address $param{submitter} is not a valid e-mail address";
921 __begin_control(%param,
922 command => 'submitter'
924 my ($debug,$transcript) =
925 @info{qw(debug transcript)};
926 my @data = @{$info{data}};
927 my @bugs = @{$info{bugs}};
929 # here we only concern ourselves with the first of the merged bugs
930 for my $data ($data[0]) {
931 my $notify_old_submitter = 0;
932 my $old_data = dclone($data);
933 print {$debug} "Going to change bug submitter\n";
934 if (((not defined $param{submitter} or not length $param{submitter}) and
935 (not defined $data->{originator} or not length $data->{originator})) or
936 (defined $param{submitter} and defined $data->{originator} and
937 $param{submitter} eq $data->{originator})) {
938 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
939 unless __internal_request();
943 if (defined $data->{originator} and length($data->{originator})) {
944 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
945 $notify_old_submitter = 1;
948 $action= "Set $config{bug} submitter to '$param{submitter}'.";
950 $data->{originator} = $param{submitter};
952 append_action_to_log(bug => $data->{bug_num},
953 command => 'submitter',
955 old_data => $old_data,
957 __return_append_to_log_options(
962 if not exists $param{append_log} or $param{append_log};
963 writebug($data->{bug_num},$data);
964 print {$transcript} "$action\n";
965 # notify old submitter
966 if ($notify_old_submitter and $param{notify_submitter}) {
967 send_mail_message(message =>
968 create_mime_message([default_headers(queue_file => $param{request_nn},
970 msgid => $param{request_msgid},
972 pr_msg => 'submitter-changed',
974 [To => $old_data->{submitter},
975 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
979 __message_body_template('mail/submitter_changed',
980 {old_data => $old_data,
982 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
986 recipients => $old_data->{submitter},
990 __end_control(%info);
998 set_forwarded(bug => $ref,
999 transcript => $transcript,
1000 ($dl > 0 ? (debug => $transcript):()),
1001 requester => $header{from},
1002 request_addr => $controlrequestaddr,
1004 affected_packages => \%affected_packages,
1005 recipients => \%recipients,
1006 forwarded => $forward_to,
1011 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1014 Sets the location to which a bug is forwarded. Given an undef
1015 forwarded, unsets forwarded.
1021 my %param = validate_with(params => \@_,
1022 spec => {bug => {type => SCALAR,
1025 # specific options here
1026 forwarded => {type => SCALAR|UNDEF,
1029 %append_action_options,
1032 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1033 die "Non-printable characters are not allowed in the forwarded field";
1036 __begin_control(%param,
1037 command => 'forwarded'
1039 my ($debug,$transcript) =
1040 @info{qw(debug transcript)};
1041 my @data = @{$info{data}};
1042 my @bugs = @{$info{bugs}};
1044 for my $data (@data) {
1045 my $old_data = dclone($data);
1046 print {$debug} "Going to change bug forwarded\n";
1047 if (((not defined $param{forwarded} or not length $param{forwarded}) and
1048 (not defined $data->{forwarded} or not length $data->{forwarded})) or
1049 $param{forwarded} eq $data->{forwarded}) {
1050 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1051 unless __internal_request();
1055 if (not defined $param{forwarded}) {
1056 $action= "Unset $config{bug} forwarded-to-address";
1058 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1059 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1062 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1064 $data->{forwarded} = $param{forwarded};
1066 append_action_to_log(bug => $data->{bug_num},
1067 command => 'forwarded',
1069 old_data => $old_data,
1071 __return_append_to_log_options(
1076 if not exists $param{append_log} or $param{append_log};
1077 writebug($data->{bug_num},$data);
1078 print {$transcript} "$action\n";
1080 __end_control(%info);
1089 set_title(bug => $ref,
1090 transcript => $transcript,
1091 ($dl > 0 ? (debug => $transcript):()),
1092 requester => $header{from},
1093 request_addr => $controlrequestaddr,
1095 affected_packages => \%affected_packages,
1096 recipients => \%recipients,
1097 title => $new_title,
1102 print {$transcript} "Failed to set the title of $ref: $@";
1105 Sets the title of a specific bug
1111 my %param = validate_with(params => \@_,
1112 spec => {bug => {type => SCALAR,
1115 # specific options here
1116 title => {type => SCALAR,
1119 %append_action_options,
1122 if ($param{title} =~ /[^[:print:]]/) {
1123 die "Non-printable characters are not allowed in bug titles";
1126 my %info = __begin_control(%param,
1129 my ($debug,$transcript) =
1130 @info{qw(debug transcript)};
1131 my @data = @{$info{data}};
1132 my @bugs = @{$info{bugs}};
1134 for my $data (@data) {
1135 my $old_data = dclone($data);
1136 print {$debug} "Going to change bug title\n";
1137 if (defined $data->{subject} and length($data->{subject}) and
1138 $data->{subject} eq $param{title}) {
1139 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1140 unless __internal_request();
1144 if (defined $data->{subject} and length($data->{subject})) {
1145 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1147 $action= "Set $config{bug} title to '$param{title}'.";
1149 $data->{subject} = $param{title};
1151 append_action_to_log(bug => $data->{bug_num},
1154 old_data => $old_data,
1156 __return_append_to_log_options(
1161 if not exists $param{append_log} or $param{append_log};
1162 writebug($data->{bug_num},$data);
1163 print {$transcript} "$action\n";
1165 __end_control(%info);
1172 set_package(bug => $ref,
1173 transcript => $transcript,
1174 ($dl > 0 ? (debug => $transcript):()),
1175 requester => $header{from},
1176 request_addr => $controlrequestaddr,
1178 affected_packages => \%affected_packages,
1179 recipients => \%recipients,
1180 package => $new_package,
1186 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1189 Indicates that a bug is in a particular package. If is_source is true,
1190 indicates that the package is a source package. [Internally, this
1191 causes src: to be prepended to the package name.]
1193 The default for is_source is 0. As a special case, if the package
1194 starts with 'src:', it is assumed to be a source package and is_source
1197 The package option must match the package_name_re regex.
1202 my %param = validate_with(params => \@_,
1203 spec => {bug => {type => SCALAR,
1206 # specific options here
1207 package => {type => SCALAR|ARRAYREF,
1209 is_source => {type => BOOLEAN,
1213 %append_action_options,
1216 my @new_packages = map {splitpackages($_)} make_list($param{package});
1217 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1218 croak "Invalid package name '".
1219 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1222 my %info = __begin_control(%param,
1223 command => 'package',
1225 my ($debug,$transcript) =
1226 @info{qw(debug transcript)};
1227 my @data = @{$info{data}};
1228 my @bugs = @{$info{bugs}};
1229 # clean up the new package
1233 ($temp =~ s/^src:// or
1234 $param{is_source}) ? 'src:'.$temp:$temp;
1238 my $package_reassigned = 0;
1239 for my $data (@data) {
1240 my $old_data = dclone($data);
1241 print {$debug} "Going to change assigned package\n";
1242 if (defined $data->{package} and length($data->{package}) and
1243 $data->{package} eq $new_package) {
1244 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1245 unless __internal_request();
1249 if (defined $data->{package} and length($data->{package})) {
1250 $package_reassigned = 1;
1251 $action= "$config{bug} reassigned from package '$data->{package}'".
1252 " to '$new_package'.";
1254 $action= "$config{bug} assigned to package '$new_package'.";
1256 $data->{package} = $new_package;
1258 append_action_to_log(bug => $data->{bug_num},
1259 command => 'package',
1261 old_data => $old_data,
1263 __return_append_to_log_options(
1268 if not exists $param{append_log} or $param{append_log};
1269 writebug($data->{bug_num},$data);
1270 print {$transcript} "$action\n";
1272 __end_control(%info);
1273 # Only clear the fixed/found versions if the package has been
1275 if ($package_reassigned) {
1276 my @params_for_found_fixed =
1277 map {exists $param{$_}?($_,$param{$_}):()}
1279 keys %common_options,
1280 keys %append_action_options,
1282 set_found(found => [],
1283 @params_for_found_fixed,
1285 set_fixed(fixed => [],
1286 @params_for_found_fixed,
1294 set_found(bug => $ref,
1295 transcript => $transcript,
1296 ($dl > 0 ? (debug => $transcript):()),
1297 requester => $header{from},
1298 request_addr => $controlrequestaddr,
1300 affected_packages => \%affected_packages,
1301 recipients => \%recipients,
1308 print {$transcript} "Failed to set found on $ref: $@";
1312 Sets, adds, or removes the specified found versions of a package
1314 If the version list is empty, and the bug is currently not "done",
1315 causes the done field to be cleared.
1317 If any of the versions added to found are greater than any version in
1318 which the bug is fixed (or when the bug is found and there are no
1319 fixed versions) the done field is cleared.
1324 my %param = validate_with(params => \@_,
1325 spec => {bug => {type => SCALAR,
1328 # specific options here
1329 found => {type => SCALAR|ARRAYREF,
1332 add => {type => BOOLEAN,
1335 remove => {type => BOOLEAN,
1339 %append_action_options,
1342 if ($param{add} and $param{remove}) {
1343 croak "It's nonsensical to add and remove the same versions";
1347 __begin_control(%param,
1350 my ($debug,$transcript) =
1351 @info{qw(debug transcript)};
1352 my @data = @{$info{data}};
1353 my @bugs = @{$info{bugs}};
1355 for my $version (make_list($param{found})) {
1356 next unless defined $version;
1357 $versions{$version} =
1358 [make_source_versions(package => [splitpackages($data[0]{package})],
1359 warnings => $transcript,
1362 versions => $version,
1365 # This is really ugly, but it's what we have to do
1366 if (not @{$versions{$version}}) {
1367 print {$transcript} "Unable to make a source version for version '$version'\n";
1370 if (not keys %versions and ($param{remove} or $param{add})) {
1371 if ($param{remove}) {
1372 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1375 print {$transcript} "Requested to add no versions; doing nothing.\n";
1377 __end_control(%info);
1380 # first things first, make the versions fully qualified source
1382 for my $data (@data) {
1383 # The 'done' field gets a bit weird with version tracking,
1384 # because a bug may be closed by multiple people in different
1385 # branches. Until we have something more flexible, we set it
1386 # every time a bug is fixed, and clear it when a bug is found
1387 # in a version greater than any version in which the bug is
1388 # fixed or when a bug is found and there is no fixed version
1389 my $action = 'Did not alter found versions';
1390 my %found_added = ();
1391 my %found_removed = ();
1392 my %fixed_removed = ();
1394 my $old_data = dclone($data);
1395 if (not $param{add} and not $param{remove}) {
1396 $found_removed{$_} = 1 for @{$data->{found_versions}};
1397 $data->{found_versions} = [];
1400 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1402 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1403 for my $version (keys %versions) {
1405 my @svers = @{$versions{$version}};
1409 for my $sver (@svers) {
1410 if (not exists $found_versions{$sver}) {
1411 $found_versions{$sver} = 1;
1412 $found_added{$sver} = 1;
1414 # if the found we are adding matches any fixed
1415 # versions, remove them
1416 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1417 delete $fixed_versions{$_} for @temp;
1418 $fixed_removed{$_} = 1 for @temp;
1421 # We only care about reopening the bug if the bug is
1423 if (defined $data->{done} and length $data->{done}) {
1424 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1425 map {m{([^/]+)$}; $1;} @svers;
1426 # determine if we need to reopen
1427 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1428 map {m{([^/]+)$}; $1;} keys %fixed_versions;
1429 if (not @fixed_order or
1430 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1436 elsif ($param{remove}) {
1437 # in the case of removal, we only concern ourself with
1438 # the version passed, not the source version it maps
1440 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1441 delete $found_versions{$_} for @temp;
1442 $found_removed{$_} = 1 for @temp;
1445 # set the keys to exactly these values
1446 my @svers = @{$versions{$version}};
1450 for my $sver (@svers) {
1451 if (not exists $found_versions{$sver}) {
1452 $found_versions{$sver} = 1;
1453 if (exists $found_removed{$sver}) {
1454 delete $found_removed{$sver};
1457 $found_added{$sver} = 1;
1464 $data->{found_versions} = [keys %found_versions];
1465 $data->{fixed_versions} = [keys %fixed_versions];
1468 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1469 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1470 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1471 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1472 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1474 $action .= " and reopened"
1476 if (not $reopened and not @changed) {
1477 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1478 unless __internal_request();
1482 append_action_to_log(bug => $data->{bug_num},
1485 old_data => $old_data,
1487 __return_append_to_log_options(
1492 if not exists $param{append_log} or $param{append_log};
1493 writebug($data->{bug_num},$data);
1494 print {$transcript} "$action\n";
1496 __end_control(%info);
1502 set_fixed(bug => $ref,
1503 transcript => $transcript,
1504 ($dl > 0 ? (debug => $transcript):()),
1505 requester => $header{from},
1506 request_addr => $controlrequestaddr,
1508 affected_packages => \%affected_packages,
1509 recipients => \%recipients,
1517 print {$transcript} "Failed to set fixed on $ref: $@";
1521 Sets, adds, or removes the specified fixed versions of a package
1523 If the fixed versions are empty (or end up being empty after this
1524 call) or the greatest fixed version is less than the greatest found
1525 version and the reopen option is true, the bug is reopened.
1527 This function is also called by the reopen function, which causes all
1528 of the fixed versions to be cleared.
1533 my %param = validate_with(params => \@_,
1534 spec => {bug => {type => SCALAR,
1537 # specific options here
1538 fixed => {type => SCALAR|ARRAYREF,
1541 add => {type => BOOLEAN,
1544 remove => {type => BOOLEAN,
1547 reopen => {type => BOOLEAN,
1551 %append_action_options,
1554 if ($param{add} and $param{remove}) {
1555 croak "It's nonsensical to add and remove the same versions";
1558 __begin_control(%param,
1561 my ($debug,$transcript) =
1562 @info{qw(debug transcript)};
1563 my @data = @{$info{data}};
1564 my @bugs = @{$info{bugs}};
1566 for my $version (make_list($param{fixed})) {
1567 next unless defined $version;
1568 $versions{$version} =
1569 [make_source_versions(package => [splitpackages($data[0]{package})],
1570 warnings => $transcript,
1573 versions => $version,
1576 # This is really ugly, but it's what we have to do
1577 if (not @{$versions{$version}}) {
1578 print {$transcript} "Unable to make a source version for version '$version'\n";
1581 if (not keys %versions and ($param{remove} or $param{add})) {
1582 if ($param{remove}) {
1583 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1586 print {$transcript} "Requested to add no versions; doing nothing.\n";
1588 __end_control(%info);
1591 # first things first, make the versions fully qualified source
1593 for my $data (@data) {
1594 my $old_data = dclone($data);
1595 # The 'done' field gets a bit weird with version tracking,
1596 # because a bug may be closed by multiple people in different
1597 # branches. Until we have something more flexible, we set it
1598 # every time a bug is fixed, and clear it when a bug is found
1599 # in a version greater than any version in which the bug is
1600 # fixed or when a bug is found and there is no fixed version
1601 my $action = 'Did not alter fixed versions';
1602 my %found_added = ();
1603 my %found_removed = ();
1604 my %fixed_added = ();
1605 my %fixed_removed = ();
1607 if (not $param{add} and not $param{remove}) {
1608 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1609 $data->{fixed_versions} = [];
1612 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1614 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1615 for my $version (keys %versions) {
1617 my @svers = @{$versions{$version}};
1621 for my $sver (@svers) {
1622 if (not exists $fixed_versions{$sver}) {
1623 $fixed_versions{$sver} = 1;
1624 $fixed_added{$sver} = 1;
1628 elsif ($param{remove}) {
1629 # in the case of removal, we only concern ourself with
1630 # the version passed, not the source version it maps
1632 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1633 delete $fixed_versions{$_} for @temp;
1634 $fixed_removed{$_} = 1 for @temp;
1637 # set the keys to exactly these values
1638 my @svers = @{$versions{$version}};
1642 for my $sver (@svers) {
1643 if (not exists $fixed_versions{$sver}) {
1644 $fixed_versions{$sver} = 1;
1645 if (exists $fixed_removed{$sver}) {
1646 delete $fixed_removed{$sver};
1649 $fixed_added{$sver} = 1;
1656 $data->{found_versions} = [keys %found_versions];
1657 $data->{fixed_versions} = [keys %fixed_versions];
1659 # If we're supposed to consider reopening, reopen if the
1660 # fixed versions are empty or the greatest found version
1661 # is greater than the greatest fixed version
1662 if ($param{reopen} and defined $data->{done}
1663 and length $data->{done}) {
1664 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1665 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1666 # determine if we need to reopen
1667 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1668 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1669 if (not @fixed_order or
1670 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1677 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1678 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1679 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1680 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1681 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1683 $action .= " and reopened"
1685 if (not $reopened and not @changed) {
1686 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1687 unless __internal_request();
1691 append_action_to_log(bug => $data->{bug_num},
1694 old_data => $old_data,
1696 __return_append_to_log_options(
1701 if not exists $param{append_log} or $param{append_log};
1702 writebug($data->{bug_num},$data);
1703 print {$transcript} "$action\n";
1705 __end_control(%info);
1713 affects(bug => $ref,
1714 transcript => $transcript,
1715 ($dl > 0 ? (debug => $transcript):()),
1716 requester => $header{from},
1717 request_addr => $controlrequestaddr,
1719 affected_packages => \%affected_packages,
1720 recipients => \%recipients,
1728 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
1731 This marks a bug as affecting packages which the bug is not actually
1732 in. This should only be used in cases where fixing the bug instantly
1733 resolves the problem in the other packages.
1735 By default, the packages are set to the list of packages passed.
1736 However, if you pass add => 1 or remove => 1, the list of packages
1737 passed are added or removed from the affects list, respectively.
1742 my %param = validate_with(params => \@_,
1743 spec => {bug => {type => SCALAR,
1746 # specific options here
1747 packages => {type => SCALAR|ARRAYREF,
1750 add => {type => BOOLEAN,
1753 remove => {type => BOOLEAN,
1757 %append_action_options,
1760 if ($param{add} and $param{remove}) {
1761 croak "Asking to both add and remove affects is nonsensical";
1764 __begin_control(%param,
1765 command => 'affects'
1767 my ($debug,$transcript) =
1768 @info{qw(debug transcript)};
1769 my @data = @{$info{data}};
1770 my @bugs = @{$info{bugs}};
1772 for my $data (@data) {
1774 print {$debug} "Going to change affects\n";
1775 my @packages = splitpackages($data->{affects});
1777 @packages{@packages} = (1) x @packages;
1780 for my $package (make_list($param{packages})) {
1781 next unless defined $package and length $package;
1782 if (not $packages{$package}) {
1783 $packages{$package} = 1;
1784 push @added,$package;
1788 $action = "Added indication that $data->{bug_num} affects ".
1789 english_join(\@added);
1792 elsif ($param{remove}) {
1794 for my $package (make_list($param{packages})) {
1795 if ($packages{$package}) {
1796 next unless defined $package and length $package;
1797 delete $packages{$package};
1798 push @removed,$package;
1801 $action = "Removed indication that $data->{bug_num} affects " .
1802 english_join(\@removed);
1805 my %added_packages = ();
1806 my %removed_packages = %packages;
1808 for my $package (make_list($param{packages})) {
1809 next unless defined $package and length $package;
1810 $packages{$package} = 1;
1811 delete $removed_packages{$package};
1812 $added_packages{$package} = 1;
1814 if (keys %removed_packages) {
1815 $action = "Removed indication that $data->{bug_num} affects ".
1816 english_join([keys %removed_packages]);
1817 $action .= "\n" if keys %added_packages;
1819 if (keys %added_packages) {
1820 $action .= "Added indication that $data->{bug_num} affects " .
1821 english_join([keys %added_packages]);
1824 if (not length $action) {
1825 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
1826 unless __internal_request();
1828 my $old_data = dclone($data);
1829 $data->{affects} = join(',',keys %packages);
1830 append_action_to_log(bug => $data->{bug_num},
1832 command => 'affects',
1834 old_data => $old_data,
1835 __return_append_to_log_options(
1840 if not exists $param{append_log} or $param{append_log};
1841 writebug($data->{bug_num},$data);
1842 print {$transcript} "$action\n";
1844 __end_control(%info);
1848 =head1 SUMMARY FUNCTIONS
1853 summary(bug => $ref,
1854 transcript => $transcript,
1855 ($dl > 0 ? (debug => $transcript):()),
1856 requester => $header{from},
1857 request_addr => $controlrequestaddr,
1859 affected_packages => \%affected_packages,
1860 recipients => \%recipients,
1866 print {$transcript} "Failed to mark $ref with summary foo: $@";
1869 Handles all setting of summary fields
1871 If summary is undef, unsets the summary
1873 If summary is 0, sets the summary to the first paragraph contained in
1876 If summary is numeric, sets the summary to the message specified.
1883 my %param = validate_with(params => \@_,
1884 spec => {bug => {type => SCALAR,
1887 # specific options here
1888 summary => {type => SCALAR|UNDEF,
1892 %append_action_options,
1895 croak "summary must be numeric or undef" if
1896 defined $param{summary} and not $param{summary} =~ /^\d+$/;
1898 __begin_control(%param,
1899 command => 'summary'
1901 my ($debug,$transcript) =
1902 @info{qw(debug transcript)};
1903 my @data = @{$info{data}};
1904 my @bugs = @{$info{bugs}};
1905 # figure out the log that we're going to use
1907 my $summary_msg = '';
1909 if (not defined $param{summary}) {
1911 print {$debug} "Removing summary fields\n";
1912 $action = 'Removed summary';
1916 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
1917 if ($param{summary} == 0) {
1918 $log = $param{message};
1919 $summary_msg = @records + 1;
1922 if (($param{summary} - 1 ) > $#records) {
1923 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
1925 my $record = $records[($param{summary} - 1 )];
1926 if ($record->{type} !~ /incoming-recv|recips/) {
1927 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
1929 $summary_msg = $param{summary};
1930 $log = [$record->{text}];
1932 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
1933 my $body = $p_o->{body};
1934 my $in_pseudoheaders = 0;
1936 # walk through body until we get non-blank lines
1937 for my $line (@{$body}) {
1938 if ($line =~ /^\s*$/) {
1939 if (length $paragraph) {
1940 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
1946 $in_pseudoheaders = 0;
1949 # skip a paragraph if it looks like it's control or
1951 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
1952 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
1953 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
1954 debug|(?:not|)forwarded|priority|
1955 (?:un|)block|limit|(?:un|)archive|
1956 reassign|retitle|affects|wrongpackage
1957 (?:un|force|)merge|user(?:category|tags?|)
1959 if (not length $paragraph) {
1960 print {$debug} "Found control/pseudo-headers and skiping them\n";
1961 $in_pseudoheaders = 1;
1965 next if $in_pseudoheaders;
1966 $paragraph .= $line ." \n";
1968 print {$debug} "Summary is going to be '$paragraph'\n";
1969 $summary = $paragraph;
1970 $summary =~ s/[\n\r]/ /g;
1971 if (not length $summary) {
1972 die "Unable to find summary message to use";
1974 # trim off a trailing spaces
1975 $summary =~ s/\ *$//;
1977 for my $data (@data) {
1978 print {$debug} "Going to change summary\n";
1979 if (((not defined $summary or not length $summary) and
1980 (not defined $data->{summary} or not length $data->{summary})) or
1981 $summary eq $data->{summary}) {
1982 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1983 unless __internal_request();
1986 if (length $summary) {
1987 if (length $data->{summary}) {
1988 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1991 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1994 my $old_data = dclone($data);
1995 $data->{summary} = $summary;
1996 append_action_to_log(bug => $data->{bug_num},
1997 command => 'summary',
1998 old_data => $old_data,
2001 __return_append_to_log_options(
2006 if not exists $param{append_log} or $param{append_log};
2007 writebug($data->{bug_num},$data);
2008 print {$transcript} "$action\n";
2010 __end_control(%info);
2016 =head1 OWNER FUNCTIONS
2022 transcript => $transcript,
2023 ($dl > 0 ? (debug => $transcript):()),
2024 requester => $header{from},
2025 request_addr => $controlrequestaddr,
2027 recipients => \%recipients,
2033 print {$transcript} "Failed to mark $ref as having an owner: $@";
2036 Handles all setting of the owner field; given an owner of undef or of
2037 no length, indicates that a bug is not owned by anyone.
2042 my %param = validate_with(params => \@_,
2043 spec => {bug => {type => SCALAR,
2046 owner => {type => SCALAR|UNDEF,
2049 %append_action_options,
2053 __begin_control(%param,
2056 my ($debug,$transcript) =
2057 @info{qw(debug transcript)};
2058 my @data = @{$info{data}};
2059 my @bugs = @{$info{bugs}};
2061 for my $data (@data) {
2062 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2063 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2064 if (not defined $param{owner} or not length $param{owner}) {
2065 if (not defined $data->{owner} or not length $data->{owner}) {
2066 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2067 unless __internal_request();
2071 $action = "Removed annotation that $config{bug} was owned by " .
2075 if ($data->{owner} eq $param{owner}) {
2076 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2079 if (length $data->{owner}) {
2080 $action = "Owner changed from $data->{owner} to $param{owner}.";
2083 $action = "Owner recorded as $param{owner}."
2086 my $old_data = dclone($data);
2087 $data->{owner} = $param{owner};
2088 append_action_to_log(bug => $data->{bug_num},
2091 old_data => $old_data,
2093 __return_append_to_log_options(
2098 if not exists $param{append_log} or $param{append_log};
2099 writebug($data->{bug_num},$data);
2100 print {$transcript} "$action\n";
2102 __end_control(%info);
2106 =head1 ARCHIVE FUNCTIONS
2113 bug_archive(bug => $bug_num,
2115 transcript => \$transcript,
2120 transcript("Unable to archive $bug_num\n");
2123 transcript($transcript);
2126 This routine archives a bug
2130 =item bug -- bug number
2132 =item check_archiveable -- check wether a bug is archiveable before
2133 archiving; defaults to 1
2135 =item archive_unarchived -- whether to archive bugs which have not
2136 previously been archived; defaults to 1. [Set to 0 when used from
2139 =item ignore_time -- whether to ignore time constraints when archiving
2140 a bug; defaults to 0.
2147 my %param = validate_with(params => \@_,
2148 spec => {bug => {type => SCALAR,
2151 check_archiveable => {type => BOOLEAN,
2154 archive_unarchived => {type => BOOLEAN,
2157 ignore_time => {type => BOOLEAN,
2161 %append_action_options,
2164 my %info = __begin_control(%param,
2165 command => 'archive',
2167 my ($debug,$transcript) = @info{qw(debug transcript)};
2168 my @data = @{$info{data}};
2169 my @bugs = @{$info{bugs}};
2170 my $action = "$config{bug} archived.";
2171 if ($param{check_archiveable} and
2172 not bug_archiveable(bug=>$param{bug},
2173 ignore_time => $param{ignore_time},
2175 print {$transcript} "Bug $param{bug} cannot be archived\n";
2176 die "Bug $param{bug} cannot be archived";
2178 print {$debug} "$param{bug} considering\n";
2179 if (not $param{archive_unarchived} and
2180 not exists $data[0]{unarchived}
2182 print {$transcript} "$param{bug} has not been archived previously\n";
2183 die "$param{bug} has not been archived previously";
2185 add_recipients(recipients => $param{recipients},
2188 transcript => $transcript,
2190 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2191 for my $bug (@bugs) {
2192 if ($param{check_archiveable}) {
2193 die "Bug $bug cannot be archived (but $param{bug} can?)"
2194 unless bug_archiveable(bug=>$bug,
2195 ignore_time => $param{ignore_time},
2199 # If we get here, we can archive/remove this bug
2200 print {$debug} "$param{bug} removing\n";
2201 for my $bug (@bugs) {
2202 #print "$param{bug} removing $bug\n" if $debug;
2203 my $dir = get_hashname($bug);
2204 # First indicate that this bug is being archived
2205 append_action_to_log(bug => $bug,
2207 command => 'archive',
2208 # we didn't actually change the data
2209 # when we archived, so we don't pass
2210 # a real new_data or old_data
2213 __return_append_to_log_options(
2218 if not exists $param{append_log} or $param{append_log};
2219 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2220 if ($config{save_old_bugs}) {
2221 mkpath("$config{spool_dir}/archive/$dir");
2222 foreach my $file (@files_to_remove) {
2223 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2224 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2225 # we need to bail out here if things have
2226 # gone horribly wrong to avoid removing a
2228 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2231 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2233 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2234 print {$transcript} "deleted $bug (from $param{bug})\n";
2236 bughook_archive(@bugs);
2237 __end_control(%info);
2240 =head2 bug_unarchive
2244 bug_unarchive(bug => $bug_num,
2246 transcript => \$transcript,
2251 transcript("Unable to archive bug: $bug_num");
2253 transcript($transcript);
2255 This routine unarchives a bug
2260 my %param = validate_with(params => \@_,
2261 spec => {bug => {type => SCALAR,
2265 %append_action_options,
2269 my %info = __begin_control(%param,
2271 command=>'unarchive');
2272 my ($debug,$transcript) =
2273 @info{qw(debug transcript)};
2274 my @data = @{$info{data}};
2275 my @bugs = @{$info{bugs}};
2276 my $action = "$config{bug} unarchived.";
2277 my @files_to_remove;
2278 for my $bug (@bugs) {
2279 print {$debug} "$param{bug} removing $bug\n";
2280 my $dir = get_hashname($bug);
2281 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
2282 mkpath("archive/$dir");
2283 foreach my $file (@files_to_copy) {
2284 # die'ing here sucks
2285 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2286 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2287 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
2289 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
2290 print {$transcript} "Unarchived $config{bug} $bug\n";
2292 unlink(@files_to_remove) or die "Unable to unlink bugs";
2293 # Indicate that this bug has been archived previously
2294 for my $bug (@bugs) {
2295 my $newdata = readbug($bug);
2296 my $old_data = dclone($newdata);
2297 if (not defined $newdata) {
2298 print {$transcript} "$config{bug} $bug disappeared!\n";
2299 die "Bug $bug disappeared!";
2301 $newdata->{unarchived} = time;
2302 append_action_to_log(bug => $bug,
2304 command => 'unarchive',
2305 new_data => $newdata,
2306 old_data => $old_data,
2307 __return_append_to_log_options(
2312 if not exists $param{append_log} or $param{append_log};
2313 writebug($bug,$newdata);
2315 __end_control(%info);
2318 =head2 append_action_to_log
2320 append_action_to_log
2322 This should probably be moved to Debbugs::Log; have to think that out
2327 sub append_action_to_log{
2328 my %param = validate_with(params => \@_,
2329 spec => {bug => {type => SCALAR,
2332 new_data => {type => HASHREF,
2335 old_data => {type => HASHREF,
2338 command => {type => SCALAR,
2341 action => {type => SCALAR,
2343 requester => {type => SCALAR,
2346 request_addr => {type => SCALAR,
2349 location => {type => SCALAR,
2352 message => {type => SCALAR|ARRAYREF,
2355 desc => {type => SCALAR,
2358 get_lock => {type => BOOLEAN,
2362 # append_action_options here
2363 # because some of these
2364 # options aren't actually
2365 # optional, even though the
2366 # original function doesn't
2370 # Fix this to use $param{location}
2371 my $log_location = buglog($param{bug});
2372 die "Unable to find .log for $param{bug}"
2373 if not defined $log_location;
2374 if ($param{get_lock}) {
2375 filelock("lock/$param{bug}");
2377 my $log = IO::File->new(">>$log_location") or
2378 die "Unable to open $log_location for appending: $!";
2379 # determine difference between old and new
2381 if (exists $param{old_data} and exists $param{new_data}) {
2382 my $old_data = dclone($param{old_data});
2383 my $new_data = dclone($param{new_data});
2384 for my $key (keys %{$old_data}) {
2385 if (not exists $Debbugs::Status::fields{$key}) {
2386 delete $old_data->{$key};
2389 next unless exists $new_data->{$key};
2390 next unless defined $new_data->{$key};
2391 if (not defined $old_data->{$key}) {
2392 delete $old_data->{$key};
2395 if (ref($new_data->{$key}) and
2396 ref($old_data->{$key}) and
2397 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2398 local $Storable::canonical = 1;
2399 # print STDERR Dumper($new_data,$old_data,$key);
2400 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2401 delete $new_data->{$key};
2402 delete $old_data->{$key};
2405 elsif ($new_data->{$key} eq $old_data->{$key}) {
2406 delete $new_data->{$key};
2407 delete $old_data->{$key};
2410 for my $key (keys %{$new_data}) {
2411 if (not exists $Debbugs::Status::fields{$key}) {
2412 delete $new_data->{$key};
2415 next unless exists $old_data->{$key};
2416 next unless defined $old_data->{$key};
2417 if (not defined $new_data->{$key} or
2418 not exists $Debbugs::Status::fields{$key}) {
2419 delete $new_data->{$key};
2422 if (ref($new_data->{$key}) and
2423 ref($old_data->{$key}) and
2424 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2425 local $Storable::canonical = 1;
2426 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2427 delete $new_data->{$key};
2428 delete $old_data->{$key};
2431 elsif ($new_data->{$key} eq $old_data->{$key}) {
2432 delete $new_data->{$key};
2433 delete $old_data->{$key};
2436 $data_diff .= "<!-- new_data:\n";
2438 for my $key (keys %{$new_data}) {
2439 if (not exists $Debbugs::Status::fields{$key}) {
2440 warn "No such field $key";
2443 $nd{$key} = $new_data->{$key};
2444 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
2446 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
2447 $data_diff .= "-->\n";
2448 $data_diff .= "<!-- old_data:\n";
2450 for my $key (keys %{$old_data}) {
2451 if (not exists $Debbugs::Status::fields{$key}) {
2452 warn "No such field $key";
2455 $od{$key} = $old_data->{$key};
2456 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
2458 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
2459 $data_diff .= "-->\n";
2461 my $msg = join('',"\6\n",
2462 (exists $param{command} ?
2463 "<!-- command:".html_escape($param{command})." -->\n":""
2465 (length $param{requester} ?
2466 "<!-- requester: ".html_escape($param{requester})." -->\n":""
2468 (length $param{request_addr} ?
2469 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
2471 "<!-- time:".time()." -->\n",
2473 "<strong>".html_escape($param{action})."</strong>\n");
2474 if (length $param{requester}) {
2475 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
2477 if (length $param{request_addr}) {
2478 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
2480 if (length $param{desc}) {
2481 $msg .= ":<br>\n$param{desc}\n";
2487 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
2488 $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
2489 or die "Unable to append to $log_location: $!";
2491 print {$log} $msg or die "Unable to append to $log_location: $!";
2492 close $log or die "Unable to close $log_location: $!";
2493 if ($param{get_lock}) {
2501 =head1 PRIVATE FUNCTIONS
2503 =head2 __handle_affected_packages
2505 __handle_affected_packages(affected_packages => {},
2513 sub __handle_affected_packages{
2514 my %param = validate_with(params => \@_,
2515 spec => {%common_options,
2516 data => {type => ARRAYREF|HASHREF
2521 for my $data (make_list($param{data})) {
2522 next unless exists $data->{package} and defined $data->{package};
2523 my @packages = split /\s*,\s*/,$data->{package};
2524 @{$param{affected_packages}}{@packages} = (1) x @packages;
2528 =head2 __handle_debug_transcript
2530 my ($debug,$transcript) = __handle_debug_transcript(%param);
2532 Returns a debug and transcript filehandle
2537 sub __handle_debug_transcript{
2538 my %param = validate_with(params => \@_,
2539 spec => {%common_options},
2542 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
2543 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
2544 return ($debug,$transcript);
2551 Produces a small bit of bug information to kick out to the transcript
2558 next unless defined $data and exists $data->{bug_num};
2559 $return .= "Bug #".($data->{bug_num}||'').
2560 ((defined $data->{done} and length $data->{done})?
2561 " {Done: $data->{done}}":''
2563 " [".($data->{package}||'(no package)'). "] ".
2564 ($data->{subject}||'(no subject)')."\n";
2570 =head2 __internal_request
2572 __internal_request()
2573 __internal_request($level)
2575 Returns true if the caller of the function calling __internal_request
2576 belongs to __PACKAGE__
2578 This allows us to be magical, and don't bother to print bug info if
2579 the second caller is from this package, amongst other things.
2581 An optional level is allowed, which increments the number of levels to
2582 check by the given value. [This is basically for use by internal
2583 functions like __begin_control which are always called by
2588 sub __internal_request{
2590 $l = 0 if not defined $l;
2591 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
2597 sub __return_append_to_log_options{
2599 my $action = $param{action} if exists $param{action};
2600 if (not exists $param{requester}) {
2601 $param{requester} = $config{control_internal_requester};
2603 if (not exists $param{request_addr}) {
2604 $param{request_addr} = $config{control_internal_request_addr};
2606 if (not exists $param{message}) {
2607 my $date = rfc822_date();
2608 $param{message} = fill_in_template(template => 'mail/fake_control_message',
2609 variables => {request_addr => $param{request_addr},
2610 requester => $param{requester},
2616 if (not defined $action) {
2617 carp "Undefined action!";
2618 $action = "unknown action";
2620 return (action => $action,
2621 (map {exists $append_action_options{$_}?($_,$param{$_}):()}
2626 =head2 __begin_control
2628 my %info = __begin_control(%param,
2630 command=>'unarchive');
2631 my ($debug,$transcript) = @info{qw(debug transcript)};
2632 my @data = @{$info{data}};
2633 my @bugs = @{$info{bugs}};
2636 Starts the process of modifying a bug; handles all of the generic
2637 things that almost every control request needs
2639 Returns a hash containing
2643 =item new_locks -- number of new locks taken out by this call
2645 =item debug -- the debug file handle
2647 =item transcript -- the transcript file handle
2649 =item data -- an arrayref containing the data of the bugs
2650 corresponding to this request
2652 =item bugs -- an arrayref containing the bug numbers of the bugs
2653 corresponding to this request
2661 sub __begin_control {
2662 my %param = validate_with(params => \@_,
2663 spec => {bug => {type => SCALAR,
2666 archived => {type => BOOLEAN,
2669 command => {type => SCALAR,
2677 my ($debug,$transcript) = __handle_debug_transcript(@_);
2678 print {$debug} "$param{bug} considering\n";
2680 my $old_die = $SIG{__DIE__};
2681 $SIG{__DIE__} = *sig_die{CODE};
2683 ($new_locks, @data) =
2684 lock_read_all_merged_bugs($param{bug},
2685 ($param{archived}?'archive':()));
2686 $locks += $new_locks;
2688 die "Unable to read any bugs successfully.";
2690 if (not $param{archived}) {
2691 for my $data (@data) {
2692 if ($data->{archived}) {
2693 die "Not altering archived bugs; see unarchive.";
2697 if (not __check_limit(data => \@data,
2698 exists $param{limit}?(limit => $param{limit}):(),
2700 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2703 __handle_affected_packages(%param,data => \@data);
2704 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2705 print {$debug} "$param{bug} read $locks locks\n";
2706 if (not @data or not defined $data[0]) {
2707 print {$transcript} "No bug found for $param{bug}\n";
2708 die "No bug found for $param{bug}";
2711 add_recipients(data => \@data,
2712 recipients => $param{recipients},
2713 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2715 (__internal_request()?(transcript => $transcript):()),
2718 print {$debug} "$param{bug} read done\n";
2719 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2720 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2721 return (data => \@data,
2723 old_die => $old_die,
2724 new_locks => $new_locks,
2726 transcript => $transcript,
2731 =head2 __end_control
2733 __end_control(%info);
2735 Handles tearing down from a control request
2741 if (exists $info{new_locks} and $info{new_locks} > 0) {
2742 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2743 for (1..$info{new_locks}) {
2747 $SIG{__DIE__} = $info{old_die};
2748 if (exists $info{param}{bugs_affected}) {
2749 @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2751 add_recipients(recipients => $info{param}{recipients},
2752 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
2753 data => $info{data},
2754 debug => $info{debug},
2755 transcript => $info{transcript},
2757 __handle_affected_packages(%{$info{param}},data=>$info{data});
2761 =head2 __check_limit
2763 __check_limit(data => \@data, limit => $param{limit});
2766 Checks to make sure that bugs match any limits; each entry of @data
2767 much satisfy the limit.
2769 Returns true if there are no entries in data, or there are no keys in
2770 limit; returns false (0) if there are any entries which do not match.
2772 The limit hashref elements can contain an arrayref of scalars to
2773 match; regexes are also acccepted. At least one of the entries in each
2774 element needs to match the corresponding field in all data for the
2781 my %param = validate_with(params => \@_,
2782 spec => {data => {type => ARRAYREF|SCALAR,
2784 limit => {type => HASHREF|UNDEF,
2788 my @data = make_list($param{data});
2790 not defined $param{limit} or
2791 not keys %{$param{limit}}) {
2794 for my $data (@data) {
2795 for my $field (keys %{$param{limit}}) {
2796 next unless exists $param{limit}{$field};
2798 for my $limit (make_list($param{limit}{$field})) {
2799 if (not ref $limit) {
2800 if ($data->{$field} eq $limit) {
2805 elsif (ref($limit) eq 'Regexp') {
2806 if ($data->{$field} =~ $limit) {
2812 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
2828 We override die to specially handle unlocking files in the cases where
2829 we are called via eval. [If we're not called via eval, it doesn't
2835 #if ($^S) { # in eval
2837 for (1..$locks) { unfilelock(); }
2844 # =head2 __message_body_template
2846 # message_body_template('mail/ack',{ref=>'foo'});
2848 # Creates a message body using a template
2852 sub __message_body_template{
2853 my ($template,$extra_var) = @_;
2855 my $hole_var = {'&bugurl' =>
2857 'http://'.$config{cgi_domain}.'/'.
2858 Debbugs::CGI::bug_url($_[0]);
2862 my $body = fill_in_template(template => $template,
2863 variables => {config => \%config,
2866 hole_var => $hole_var,
2868 return fill_in_template(template => 'mail/message_body',
2869 variables => {config => \%config,
2873 hole_var => $hole_var,