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)\:| #pseudo headers
1952 (?:package|(?:no|)owner|severity|tag|summary| #control
1953 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
1954 (?:force|)merge|user(?:category|tag|)
1957 if (not length $paragraph) {
1958 print {$debug} "Found control/pseudo-headers and skiping them\n";
1959 $in_pseudoheaders = 1;
1963 next if $in_pseudoheaders;
1964 $paragraph .= $line ." \n";
1966 print {$debug} "Summary is going to be '$paragraph'\n";
1967 $summary = $paragraph;
1968 $summary =~ s/[\n\r]/ /g;
1969 if (not length $summary) {
1970 die "Unable to find summary message to use";
1972 # trim off a trailing spaces
1973 $summary =~ s/\ *$//;
1975 for my $data (@data) {
1976 print {$debug} "Going to change summary\n";
1977 if (((not defined $summary or not length $summary) and
1978 (not defined $data->{summary} or not length $data->{summary})) or
1979 $summary eq $data->{summary}) {
1980 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1981 unless __internal_request();
1984 if (length $summary) {
1985 if (length $data->{summary}) {
1986 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1989 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1992 my $old_data = dclone($data);
1993 $data->{summary} = $summary;
1994 append_action_to_log(bug => $data->{bug_num},
1995 command => 'summary',
1996 old_data => $old_data,
1999 __return_append_to_log_options(
2004 if not exists $param{append_log} or $param{append_log};
2005 writebug($data->{bug_num},$data);
2006 print {$transcript} "$action\n";
2008 __end_control(%info);
2014 =head1 OWNER FUNCTIONS
2020 transcript => $transcript,
2021 ($dl > 0 ? (debug => $transcript):()),
2022 requester => $header{from},
2023 request_addr => $controlrequestaddr,
2025 recipients => \%recipients,
2031 print {$transcript} "Failed to mark $ref as having an owner: $@";
2034 Handles all setting of the owner field; given an owner of undef or of
2035 no length, indicates that a bug is not owned by anyone.
2040 my %param = validate_with(params => \@_,
2041 spec => {bug => {type => SCALAR,
2044 owner => {type => SCALAR|UNDEF,
2047 %append_action_options,
2051 __begin_control(%param,
2054 my ($debug,$transcript) =
2055 @info{qw(debug transcript)};
2056 my @data = @{$info{data}};
2057 my @bugs = @{$info{bugs}};
2059 for my $data (@data) {
2060 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2061 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2062 if (not defined $param{owner} or not length $param{owner}) {
2063 if (not defined $data->{owner} or not length $data->{owner}) {
2064 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2065 unless __internal_request();
2069 $action = "Removed annotation that $config{bug} was owned by " .
2073 if ($data->{owner} eq $param{owner}) {
2074 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2077 if (length $data->{owner}) {
2078 $action = "Owner changed from $data->{owner} to $param{owner}.";
2081 $action = "Owner recorded as $param{owner}."
2084 my $old_data = dclone($data);
2085 $data->{owner} = $param{owner};
2086 append_action_to_log(bug => $data->{bug_num},
2089 old_data => $old_data,
2091 __return_append_to_log_options(
2096 if not exists $param{append_log} or $param{append_log};
2097 writebug($data->{bug_num},$data);
2098 print {$transcript} "$action\n";
2100 __end_control(%info);
2104 =head1 ARCHIVE FUNCTIONS
2111 bug_archive(bug => $bug_num,
2113 transcript => \$transcript,
2118 transcript("Unable to archive $bug_num\n");
2121 transcript($transcript);
2124 This routine archives a bug
2128 =item bug -- bug number
2130 =item check_archiveable -- check wether a bug is archiveable before
2131 archiving; defaults to 1
2133 =item archive_unarchived -- whether to archive bugs which have not
2134 previously been archived; defaults to 1. [Set to 0 when used from
2137 =item ignore_time -- whether to ignore time constraints when archiving
2138 a bug; defaults to 0.
2145 my %param = validate_with(params => \@_,
2146 spec => {bug => {type => SCALAR,
2149 check_archiveable => {type => BOOLEAN,
2152 archive_unarchived => {type => BOOLEAN,
2155 ignore_time => {type => BOOLEAN,
2159 %append_action_options,
2162 my %info = __begin_control(%param,
2163 command => 'archive',
2165 my ($debug,$transcript) = @info{qw(debug transcript)};
2166 my @data = @{$info{data}};
2167 my @bugs = @{$info{bugs}};
2168 my $action = "$config{bug} archived.";
2169 if ($param{check_archiveable} and
2170 not bug_archiveable(bug=>$param{bug},
2171 ignore_time => $param{ignore_time},
2173 print {$transcript} "Bug $param{bug} cannot be archived\n";
2174 die "Bug $param{bug} cannot be archived";
2176 print {$debug} "$param{bug} considering\n";
2177 if (not $param{archive_unarchived} and
2178 not exists $data[0]{unarchived}
2180 print {$transcript} "$param{bug} has not been archived previously\n";
2181 die "$param{bug} has not been archived previously";
2183 add_recipients(recipients => $param{recipients},
2186 transcript => $transcript,
2188 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2189 for my $bug (@bugs) {
2190 if ($param{check_archiveable}) {
2191 die "Bug $bug cannot be archived (but $param{bug} can?)"
2192 unless bug_archiveable(bug=>$bug,
2193 ignore_time => $param{ignore_time},
2197 # If we get here, we can archive/remove this bug
2198 print {$debug} "$param{bug} removing\n";
2199 for my $bug (@bugs) {
2200 #print "$param{bug} removing $bug\n" if $debug;
2201 my $dir = get_hashname($bug);
2202 # First indicate that this bug is being archived
2203 append_action_to_log(bug => $bug,
2205 command => 'archive',
2206 # we didn't actually change the data
2207 # when we archived, so we don't pass
2208 # a real new_data or old_data
2211 __return_append_to_log_options(
2216 if not exists $param{append_log} or $param{append_log};
2217 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2218 if ($config{save_old_bugs}) {
2219 mkpath("$config{spool_dir}/archive/$dir");
2220 foreach my $file (@files_to_remove) {
2221 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2222 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2223 # we need to bail out here if things have
2224 # gone horribly wrong to avoid removing a
2226 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2229 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2231 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2232 print {$transcript} "deleted $bug (from $param{bug})\n";
2234 bughook_archive(@bugs);
2235 __end_control(%info);
2238 =head2 bug_unarchive
2242 bug_unarchive(bug => $bug_num,
2244 transcript => \$transcript,
2249 transcript("Unable to archive bug: $bug_num");
2251 transcript($transcript);
2253 This routine unarchives a bug
2258 my %param = validate_with(params => \@_,
2259 spec => {bug => {type => SCALAR,
2263 %append_action_options,
2267 my %info = __begin_control(%param,
2269 command=>'unarchive');
2270 my ($debug,$transcript) =
2271 @info{qw(debug transcript)};
2272 my @data = @{$info{data}};
2273 my @bugs = @{$info{bugs}};
2274 my $action = "$config{bug} unarchived.";
2275 my @files_to_remove;
2276 for my $bug (@bugs) {
2277 print {$debug} "$param{bug} removing $bug\n";
2278 my $dir = get_hashname($bug);
2279 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
2280 mkpath("archive/$dir");
2281 foreach my $file (@files_to_copy) {
2282 # die'ing here sucks
2283 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2284 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2285 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
2287 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
2288 print {$transcript} "Unarchived $config{bug} $bug\n";
2290 unlink(@files_to_remove) or die "Unable to unlink bugs";
2291 # Indicate that this bug has been archived previously
2292 for my $bug (@bugs) {
2293 my $newdata = readbug($bug);
2294 my $old_data = dclone($newdata);
2295 if (not defined $newdata) {
2296 print {$transcript} "$config{bug} $bug disappeared!\n";
2297 die "Bug $bug disappeared!";
2299 $newdata->{unarchived} = time;
2300 append_action_to_log(bug => $bug,
2302 command => 'unarchive',
2303 new_data => $newdata,
2304 old_data => $old_data,
2305 __return_append_to_log_options(
2310 if not exists $param{append_log} or $param{append_log};
2311 writebug($bug,$newdata);
2313 __end_control(%info);
2316 =head2 append_action_to_log
2318 append_action_to_log
2320 This should probably be moved to Debbugs::Log; have to think that out
2325 sub append_action_to_log{
2326 my %param = validate_with(params => \@_,
2327 spec => {bug => {type => SCALAR,
2330 new_data => {type => HASHREF,
2333 old_data => {type => HASHREF,
2336 command => {type => SCALAR,
2339 action => {type => SCALAR,
2341 requester => {type => SCALAR,
2344 request_addr => {type => SCALAR,
2347 location => {type => SCALAR,
2350 message => {type => SCALAR|ARRAYREF,
2353 desc => {type => SCALAR,
2356 get_lock => {type => BOOLEAN,
2360 # append_action_options here
2361 # because some of these
2362 # options aren't actually
2363 # optional, even though the
2364 # original function doesn't
2368 # Fix this to use $param{location}
2369 my $log_location = buglog($param{bug});
2370 die "Unable to find .log for $param{bug}"
2371 if not defined $log_location;
2372 if ($param{get_lock}) {
2373 filelock("lock/$param{bug}");
2375 my $log = IO::File->new(">>$log_location") or
2376 die "Unable to open $log_location for appending: $!";
2377 # determine difference between old and new
2379 if (exists $param{old_data} and exists $param{new_data}) {
2380 my $old_data = dclone($param{old_data});
2381 my $new_data = dclone($param{new_data});
2382 for my $key (keys %{$old_data}) {
2383 if (not exists $Debbugs::Status::fields{$key}) {
2384 delete $old_data->{$key};
2387 next unless exists $new_data->{$key};
2388 next unless defined $new_data->{$key};
2389 if (not defined $old_data->{$key}) {
2390 delete $old_data->{$key};
2393 if (ref($new_data->{$key}) and
2394 ref($old_data->{$key}) and
2395 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2396 local $Storable::canonical = 1;
2397 # print STDERR Dumper($new_data,$old_data,$key);
2398 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2399 delete $new_data->{$key};
2400 delete $old_data->{$key};
2403 elsif ($new_data->{$key} eq $old_data->{$key}) {
2404 delete $new_data->{$key};
2405 delete $old_data->{$key};
2408 for my $key (keys %{$new_data}) {
2409 if (not exists $Debbugs::Status::fields{$key}) {
2410 delete $new_data->{$key};
2413 next unless exists $old_data->{$key};
2414 next unless defined $old_data->{$key};
2415 if (not defined $new_data->{$key} or
2416 not exists $Debbugs::Status::fields{$key}) {
2417 delete $new_data->{$key};
2420 if (ref($new_data->{$key}) and
2421 ref($old_data->{$key}) and
2422 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2423 local $Storable::canonical = 1;
2424 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2425 delete $new_data->{$key};
2426 delete $old_data->{$key};
2429 elsif ($new_data->{$key} eq $old_data->{$key}) {
2430 delete $new_data->{$key};
2431 delete $old_data->{$key};
2434 $data_diff .= "<!-- new_data:\n";
2436 for my $key (keys %{$new_data}) {
2437 if (not exists $Debbugs::Status::fields{$key}) {
2438 warn "No such field $key";
2441 $nd{$key} = $new_data->{$key};
2442 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
2444 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
2445 $data_diff .= "-->\n";
2446 $data_diff .= "<!-- old_data:\n";
2448 for my $key (keys %{$old_data}) {
2449 if (not exists $Debbugs::Status::fields{$key}) {
2450 warn "No such field $key";
2453 $od{$key} = $old_data->{$key};
2454 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
2456 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
2457 $data_diff .= "-->\n";
2459 my $msg = join('',"\6\n",
2460 (exists $param{command} ?
2461 "<!-- command:".html_escape($param{command})." -->\n":""
2463 (length $param{requester} ?
2464 "<!-- requester: ".html_escape($param{requester})." -->\n":""
2466 (length $param{request_addr} ?
2467 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
2469 "<!-- time:".time()." -->\n",
2471 "<strong>".html_escape($param{action})."</strong>\n");
2472 if (length $param{requester}) {
2473 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
2475 if (length $param{request_addr}) {
2476 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
2478 if (length $param{desc}) {
2479 $msg .= ":<br>\n$param{desc}\n";
2485 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
2486 $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
2487 or die "Unable to append to $log_location: $!";
2489 print {$log} $msg or die "Unable to append to $log_location: $!";
2490 close $log or die "Unable to close $log_location: $!";
2491 if ($param{get_lock}) {
2499 =head1 PRIVATE FUNCTIONS
2501 =head2 __handle_affected_packages
2503 __handle_affected_packages(affected_packages => {},
2511 sub __handle_affected_packages{
2512 my %param = validate_with(params => \@_,
2513 spec => {%common_options,
2514 data => {type => ARRAYREF|HASHREF
2519 for my $data (make_list($param{data})) {
2520 next unless exists $data->{package} and defined $data->{package};
2521 my @packages = split /\s*,\s*/,$data->{package};
2522 @{$param{affected_packages}}{@packages} = (1) x @packages;
2526 =head2 __handle_debug_transcript
2528 my ($debug,$transcript) = __handle_debug_transcript(%param);
2530 Returns a debug and transcript filehandle
2535 sub __handle_debug_transcript{
2536 my %param = validate_with(params => \@_,
2537 spec => {%common_options},
2540 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
2541 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
2542 return ($debug,$transcript);
2549 Produces a small bit of bug information to kick out to the transcript
2556 next unless defined $data and exists $data->{bug_num};
2557 $return .= "Bug #".($data->{bug_num}||'').
2558 ((defined $data->{done} and length $data->{done})?
2559 " {Done: $data->{done}}":''
2561 " [".($data->{package}||'(no package)'). "] ".
2562 ($data->{subject}||'(no subject)')."\n";
2568 =head2 __internal_request
2570 __internal_request()
2571 __internal_request($level)
2573 Returns true if the caller of the function calling __internal_request
2574 belongs to __PACKAGE__
2576 This allows us to be magical, and don't bother to print bug info if
2577 the second caller is from this package, amongst other things.
2579 An optional level is allowed, which increments the number of levels to
2580 check by the given value. [This is basically for use by internal
2581 functions like __begin_control which are always called by
2586 sub __internal_request{
2588 $l = 0 if not defined $l;
2589 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
2595 sub __return_append_to_log_options{
2597 my $action = $param{action} if exists $param{action};
2598 if (not exists $param{requester}) {
2599 $param{requester} = $config{control_internal_requester};
2601 if (not exists $param{request_addr}) {
2602 $param{request_addr} = $config{control_internal_request_addr};
2604 if (not exists $param{message}) {
2605 my $date = rfc822_date();
2606 $param{message} = fill_in_template(template => 'mail/fake_control_message',
2607 variables => {request_addr => $param{request_addr},
2608 requester => $param{requester},
2614 if (not defined $action) {
2615 carp "Undefined action!";
2616 $action = "unknown action";
2618 return (action => $action,
2619 (map {exists $append_action_options{$_}?($_,$param{$_}):()}
2624 =head2 __begin_control
2626 my %info = __begin_control(%param,
2628 command=>'unarchive');
2629 my ($debug,$transcript) = @info{qw(debug transcript)};
2630 my @data = @{$info{data}};
2631 my @bugs = @{$info{bugs}};
2634 Starts the process of modifying a bug; handles all of the generic
2635 things that almost every control request needs
2637 Returns a hash containing
2641 =item new_locks -- number of new locks taken out by this call
2643 =item debug -- the debug file handle
2645 =item transcript -- the transcript file handle
2647 =item data -- an arrayref containing the data of the bugs
2648 corresponding to this request
2650 =item bugs -- an arrayref containing the bug numbers of the bugs
2651 corresponding to this request
2659 sub __begin_control {
2660 my %param = validate_with(params => \@_,
2661 spec => {bug => {type => SCALAR,
2664 archived => {type => BOOLEAN,
2667 command => {type => SCALAR,
2675 my ($debug,$transcript) = __handle_debug_transcript(@_);
2676 print {$debug} "$param{bug} considering\n";
2678 my $old_die = $SIG{__DIE__};
2679 $SIG{__DIE__} = *sig_die{CODE};
2681 ($new_locks, @data) =
2682 lock_read_all_merged_bugs($param{bug},
2683 ($param{archived}?'archive':()));
2684 $locks += $new_locks;
2686 die "Unable to read any bugs successfully.";
2688 if (not $param{archived}) {
2689 for my $data (@data) {
2690 if ($data->{archived}) {
2691 die "Not altering archived bugs; see unarchive.";
2695 if (not __check_limit(data => \@data,
2696 exists $param{limit}?(limit => $param{limit}):(),
2698 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2701 __handle_affected_packages(%param,data => \@data);
2702 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2703 print {$debug} "$param{bug} read $locks locks\n";
2704 if (not @data or not defined $data[0]) {
2705 print {$transcript} "No bug found for $param{bug}\n";
2706 die "No bug found for $param{bug}";
2709 add_recipients(data => \@data,
2710 recipients => $param{recipients},
2711 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2713 (__internal_request()?(transcript => $transcript):()),
2716 print {$debug} "$param{bug} read done\n";
2717 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2718 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2719 return (data => \@data,
2721 old_die => $old_die,
2722 new_locks => $new_locks,
2724 transcript => $transcript,
2729 =head2 __end_control
2731 __end_control(%info);
2733 Handles tearing down from a control request
2739 if (exists $info{new_locks} and $info{new_locks} > 0) {
2740 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2741 for (1..$info{new_locks}) {
2745 $SIG{__DIE__} = $info{old_die};
2746 if (exists $info{param}{bugs_affected}) {
2747 @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2749 add_recipients(recipients => $info{param}{recipients},
2750 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
2751 data => $info{data},
2752 debug => $info{debug},
2753 transcript => $info{transcript},
2755 __handle_affected_packages(%{$info{param}},data=>$info{data});
2759 =head2 __check_limit
2761 __check_limit(data => \@data, limit => $param{limit});
2764 Checks to make sure that bugs match any limits; each entry of @data
2765 much satisfy the limit.
2767 Returns true if there are no entries in data, or there are no keys in
2768 limit; returns false (0) if there are any entries which do not match.
2770 The limit hashref elements can contain an arrayref of scalars to
2771 match; regexes are also acccepted. At least one of the entries in each
2772 element needs to match the corresponding field in all data for the
2779 my %param = validate_with(params => \@_,
2780 spec => {data => {type => ARRAYREF|SCALAR,
2782 limit => {type => HASHREF|UNDEF,
2786 my @data = make_list($param{data});
2788 not defined $param{limit} or
2789 not keys %{$param{limit}}) {
2792 for my $data (@data) {
2793 for my $field (keys %{$param{limit}}) {
2794 next unless exists $param{limit}{$field};
2796 for my $limit (make_list($param{limit}{$field})) {
2797 if (not ref $limit) {
2798 if ($data->{$field} eq $limit) {
2803 elsif (ref($limit) eq 'Regexp') {
2804 if ($data->{$field} =~ $limit) {
2810 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
2826 We override die to specially handle unlocking files in the cases where
2827 we are called via eval. [If we're not called via eval, it doesn't
2833 #if ($^S) { # in eval
2835 for (1..$locks) { unfilelock(); }
2842 # =head2 __message_body_template
2844 # message_body_template('mail/ack',{ref=>'foo'});
2846 # Creates a message body using a template
2850 sub __message_body_template{
2851 my ($template,$extra_var) = @_;
2853 my $hole_var = {'&bugurl' =>
2855 'http://'.$config{cgi_domain}.'/'.
2856 Debbugs::CGI::bug_url($_[0]);
2860 my $body = fill_in_template(template => $template,
2861 variables => {config => \%config,
2864 hole_var => $hole_var,
2866 return fill_in_template(template => 'mail/message_body',
2867 variables => {config => \%config,
2871 hole_var => $hole_var,