1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Control;
14 Debbugs::Control -- Routines for modifying the state of bugs
23 This module is an abstraction of a lot of functions which originally
24 were only present in service.in, but as time has gone on needed to be
25 called from elsewhere.
27 All of the public functions take the following options:
31 =item debug -- scalar reference to which debbuging information is
34 =item transcript -- scalar reference to which transcript information
37 =item affected_bugs -- hashref which is updated with bugs affected by
43 Functions which should (probably) append to the .log file take the
48 =item requester -- Email address of the individual who requested the change
50 =item request_addr -- Address to which the request was sent
52 =item request_nn -- Name of queue file which caused this request
54 =item request_msgid -- Message id of message which caused this request
56 =item location -- Optional location; currently ignored but may be
57 supported in the future for updating archived bugs upon archival
59 =item message -- The original message which caused the action to be taken
61 =item append_log -- Whether or not to append information to the log.
65 B<append_log> (for most functions) is a special option. When set to
66 false, no appending to the log is done at all. When it is not present,
67 the above information is faked, and appended to the log file. When it
68 is true, the above options must be present, and their values are used.
71 =head1 GENERAL FUNCTIONS
77 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
78 use base qw(Exporter);
82 $DEBUG = 0 unless defined $DEBUG;
85 %EXPORT_TAGS = (reopen => [qw(reopen)],
86 submitter => [qw(set_submitter)],
87 severity => [qw(set_severity)],
88 affects => [qw(affects)],
89 summary => [qw(summary)],
91 title => [qw(set_title)],
92 forward => [qw(set_forwarded)],
93 found => [qw(set_found set_fixed)],
94 fixed => [qw(set_found set_fixed)],
95 package => [qw(set_package)],
96 block => [qw(set_blocks)],
97 archive => [qw(bug_archive bug_unarchive),
99 log => [qw(append_action_to_log),
103 Exporter::export_ok_tags(keys %EXPORT_TAGS);
104 $EXPORT_TAGS{all} = [@EXPORT_OK];
107 use Debbugs::Config qw(:config);
108 use Debbugs::Common qw(:lock buglog :misc get_hashname);
109 use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages split_status_fields);
110 use Debbugs::CGI qw(html_escape);
111 use Debbugs::Log qw(:misc);
112 use Debbugs::Recipients qw(:add);
113 use Debbugs::Packages qw(:versions :mapping);
115 use Params::Validate qw(validate_with :types);
116 use File::Path qw(mkpath);
119 use Debbugs::Text qw(:templates);
121 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
122 use Debbugs::MIME qw(create_mime_message);
124 use Mail::RFC822::Address qw();
126 use POSIX qw(strftime);
128 use Storable qw(dclone nfreeze);
129 use List::Util qw(first);
133 # These are a set of options which are common to all of these functions
135 my %common_options = (debug => {type => SCALARREF|HANDLE,
138 transcript => {type => SCALARREF|HANDLE,
141 affected_bugs => {type => HASHREF,
144 affected_packages => {type => HASHREF,
147 recipients => {type => HASHREF,
150 limit => {type => HASHREF,
153 show_bug_info => {type => BOOLEAN,
156 request_subject => {type => SCALAR,
157 default => 'Unknown Subject',
159 request_msgid => {type => SCALAR,
162 request_nn => {type => SCALAR,
165 request_replyto => {type => SCALAR,
171 my %append_action_options =
172 (action => {type => SCALAR,
175 requester => {type => SCALAR,
178 request_addr => {type => SCALAR,
181 location => {type => SCALAR,
184 message => {type => SCALAR|ARRAYREF,
187 append_log => {type => BOOLEAN,
189 depends => [qw(requester request_addr),
196 # this is just a generic stub for Debbugs::Control functions.
201 # set_foo(bug => $ref,
202 # transcript => $transcript,
203 # ($dl > 0 ? (debug => $transcript):()),
204 # requester => $header{from},
205 # request_addr => $controlrequestaddr,
207 # affected_packages => \%affected_packages,
208 # recipients => \%recipients,
214 # print {$transcript} "Failed to set foo $ref bar: $@";
222 # my %param = validate_with(params => \@_,
223 # spec => {bug => {type => SCALAR,
224 # regex => qr/^\d+$/,
226 # # specific options here
228 # %append_action_options,
232 # __begin_control(%param,
235 # my ($debug,$transcript) =
236 # @info{qw(debug transcript)};
237 # my @data = @{$info{data}};
238 # my @bugs = @{$info{bugs}};
241 # for my $data (@data) {
242 # append_action_to_log(bug => $data->{bug_num},
244 # __return_append_to_log_options(
249 # if not exists $param{append_log} or $param{append_log};
250 # writebug($data->{bug_num},$data);
251 # print {$transcript} "$action\n";
253 # __end_control(%info);
260 set_block(bug => $ref,
261 transcript => $transcript,
262 ($dl > 0 ? (debug => $transcript):()),
263 requester => $header{from},
264 request_addr => $controlrequestaddr,
266 affected_packages => \%affected_packages,
267 recipients => \%recipients,
273 print {$transcript} "Failed to set blockers of $ref: $@";
276 Alters the set of bugs that block this bug from being fixed
278 This requires altering both this bug (and those it's merged with) as
279 well as the bugs that block this bug from being fixed (and those that
284 =item block -- scalar or arrayref of blocking bugs to set, add or remove
286 =item add -- if true, add blocking bugs
288 =item remove -- if true, remove blocking bugs
295 my %param = validate_with(params => \@_,
296 spec => {bug => {type => SCALAR,
299 # specific options here
300 block => {type => SCALAR|ARRAYREF,
303 add => {type => BOOLEAN,
306 remove => {type => BOOLEAN,
310 %append_action_options,
313 if ($param{add} and $param{remove}) {
314 croak "It's nonsensical to add and remove the same blocking bugs";
316 if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
317 croak "Invalid blocking bug(s):".
318 join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
321 if (exists $param{add}) {
324 elsif (exists $param{remove}) {
329 __begin_control(%param,
332 my ($debug,$transcript) =
333 @info{qw(debug transcript)};
334 my @data = @{$info{data}};
335 my @bugs = @{$info{bugs}};
338 # The first bit of this code is ugly, and should be cleaned up.
339 # Its purpose is to populate %removed_blockers and %add_blockers
340 # with all of the bugs that should be added or removed as blockers
341 # of all of the bugs which are merged with $param{bug}
344 for my $blocker (make_list($param{block})) {
345 next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
346 my $data = read_bug(bug=>$blocker,
348 if (defined $data and not $data->{archive}) {
349 $data = split_status_fields($data);
350 $ok_blockers{$blocker} = 1;
352 push @merged_bugs, make_list($data->{mergedwith});
353 $ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
356 $bad_blockers{$blocker} = 1;
360 # throw an error if we are setting the blockers and there is a bad
362 if (keys %bad_blockers and $mode eq 'set') {
363 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
364 keys %ok_blockers?'':" and no known blocking bug(s)";
366 # if there are no ok blockers and we are not setting the blockers,
368 if (not keys %ok_blockers and $mode ne 'set') {
369 print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
370 if (keys %bad_blockers) {
371 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
373 __end_control(%info);
377 my @change_blockers = keys %ok_blockers;
379 my %removed_blockers;
382 my @blockers = map {split ' ', $_->{blockedby}} @data;
384 @blockers{@blockers} = (1) x @blockers;
386 # it is nonsensical for a bug to block itself (or a merged
387 # partner); We currently don't allow removal because we'd possibly
391 @bugs{@bugs} = (1) x @bugs;
392 for my $blocker (@change_blockers) {
393 if ($bugs{$blocker}) {
394 croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
397 @blockers = keys %blockers;
399 %removed_blockers = ();
400 for my $blocker (@change_blockers) {
401 next if exists $blockers{$blocker};
402 $blockers{$blocker} = 1;
403 $added_blockers{$blocker} = 1;
406 elsif ($param{remove}) {
407 %added_blockers = ();
408 for my $blocker (@change_blockers) {
409 next if exists $removed_blockers{$blocker};
410 delete $blockers{$blocker};
411 $removed_blockers{$blocker} = 1;
415 @removed_blockers{@blockers} = (1) x @blockers;
417 for my $blocker (@change_blockers) {
418 next if exists $blockers{$blocker};
419 $blockers{$blocker} = 1;
420 if (exists $removed_blockers{$blocker}) {
421 delete $removed_blockers{$blocker};
424 $added_blockers{$blocker} = 1;
428 my @new_blockers = keys %blockers;
429 for my $data (@data) {
430 my $old_data = dclone($data);
431 # remove blockers and/or add new ones as appropriate
432 if ($data->{blockedby} eq '') {
433 print {$transcript} "Was not blocked by any bugs.\n";
435 print {$transcript} "Was blocked by: $data->{blockedby}\n";
438 push @changed, 'added blocking bug(s) '.english_join([keys %added_blockers]) if keys %added_blockers;
439 push @changed, 'removed blocking bug(s) '.english_join([keys %removed_blockers]) if keys %removed_blockers;
440 $action = ucfirst(join ('; ',@changed)) if @changed;
442 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
443 unless __internal_request();
446 $data->{blockedby} = join(' ',keys %blockers);
447 append_action_to_log(bug => $data->{bug_num},
449 old_data => $old_data,
452 __return_append_to_log_options(
457 if not exists $param{append_log} or $param{append_log};
458 writebug($data->{bug_num},$data);
459 print {$transcript} "$action\n";
461 # we do this bit below to avoid code duplication
463 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
464 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
465 for my $add_remove (keys %mungable_blocks) {
469 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
470 next if $munge_blockers{$blocker};
471 my ($new_locks, @blocking_data) =
472 lock_read_all_merged_bugs($blocker,
473 ($param{archived}?'archive':()));
474 if (not @blocking_data) {
475 unfilelock() for $new_locks;
476 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
478 for (map {$_->{bug_num}} @blocking_data) {
479 $munge_blockers{$_} = 1;
481 for my $data (@blocking_data) {
482 my $old_data = dclone($data);
484 %blocks = split ' ', $data->{blocks};
486 for my $bug (@bugs) {
487 if ($add_remove eq 'remove') {
488 next unless exists $blocks{$bug};
489 delete $blocks{$bug};
492 next if exists $blocks{$bug};
497 $data->{blocks} = join(' ',sort keys %blocks);
498 my $action = ($add_remove eq 'add'?'Added':'Removed').
499 " indication that bug $data->{bug_num} blocks".
501 append_action_to_log(bug => $data->{bug_num},
503 old_data => $old_data,
506 __return_append_to_log_options(%param,
511 __handle_affected_packages(%param,data=>\@blocking_data);
512 add_recipients(recipients => $param{recipients},
513 actions_taken => {blocks => 1},
514 data => \@blocking_data,
516 transcript => $transcript,
519 unfilelock() for $new_locks;
522 __end_control(%info);
531 transcript => $transcript,
532 ($dl > 0 ? (debug => $transcript):()),
533 requester => $header{from},
534 request_addr => $controlrequestaddr,
536 affected_packages => \%affected_packages,
537 recipients => \%recipients,
544 print {$transcript} "Failed to set tag on $ref: $@";
548 Sets, adds, or removes the specified tags on a bug
552 =item tag -- scalar or arrayref of tags to set, add or remove
554 =item add -- if true, add tags
556 =item remove -- if true, remove tags
558 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
566 my %param = validate_with(params => \@_,
567 spec => {bug => {type => SCALAR,
570 # specific options here
571 tag => {type => SCALAR|ARRAYREF,
574 add => {type => BOOLEAN,
577 remove => {type => BOOLEAN,
580 warn_on_bad_tags => {type => BOOLEAN,
584 %append_action_options,
587 if ($param{add} and $param{remove}) {
588 croak "It's nonsensical to add and remove the same tags";
592 __begin_control(%param,
595 my ($debug,$transcript) =
596 @info{qw(debug transcript)};
597 my @data = @{$info{data}};
598 my @bugs = @{$info{bugs}};
599 my @tags = make_list($param{tag});
600 if (not @tags and ($param{remove} or $param{add})) {
601 if ($param{remove}) {
602 print {$transcript} "Requested to remove no tags; doing nothing.\n";
605 print {$transcript} "Requested to add no tags; doing nothing.\n";
607 __end_control(%info);
610 # first things first, make the versions fully qualified source
612 for my $data (@data) {
613 my $action = 'Did not alter tags';
615 my %tag_removed = ();
616 my %fixed_removed = ();
617 my @old_tags = split /\,\s*/, $data->{tags};
619 @tags{@old_tags} = (1) x @old_tags;
621 my $old_data = dclone($data);
622 if (not $param{add} and not $param{remove}) {
623 $tag_removed{$_} = 1 for @old_tags;
627 for my $tag (@tags) {
628 if (not $param{remove} and
629 not defined first {$_ eq $tag} @{$config{tags}}) {
630 push @bad_tags, $tag;
634 if (not exists $tags{$tag}) {
636 $tag_added{$tag} = 1;
639 elsif ($param{remove}) {
640 if (exists $tags{$tag}) {
642 $tag_removed{$tag} = 1;
646 if (exists $tag_removed{$tag}) {
647 delete $tag_removed{$tag};
650 $tag_added{$tag} = 1;
655 if (@bad_tags and $param{warn_on_bad_tags}) {
656 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
657 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
659 $data->{tags} = join(', ',keys %tags); # double check this
662 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
663 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
664 $action = ucfirst(join ('; ',@changed)) if @changed;
666 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
667 unless __internal_request();
671 append_action_to_log(bug => $data->{bug_num},
674 old_data => $old_data,
676 __return_append_to_log_options(
681 if not exists $param{append_log} or $param{append_log};
682 writebug($data->{bug_num},$data);
683 print {$transcript} "$action\n";
685 __end_control(%info);
693 set_severity(bug => $ref,
694 transcript => $transcript,
695 ($dl > 0 ? (debug => $transcript):()),
696 requester => $header{from},
697 request_addr => $controlrequestaddr,
699 affected_packages => \%affected_packages,
700 recipients => \%recipients,
701 severity => 'normal',
706 print {$transcript} "Failed to set the severity of bug $ref: $@";
709 Sets the severity of a bug. If severity is not passed, is undefined,
710 or has zero length, sets the severity to the defafult severity.
715 my %param = validate_with(params => \@_,
716 spec => {bug => {type => SCALAR,
719 # specific options here
720 severity => {type => SCALAR|UNDEF,
721 default => $config{default_severity},
724 %append_action_options,
727 if (not defined $param{severity} or
728 not length $param{severity}
730 $param{severity} = $config{default_severity};
733 # check validity of new severity
734 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
735 die "Severity '$param{severity}' is not a valid severity level";
738 __begin_control(%param,
739 command => 'severity'
741 my ($debug,$transcript) =
742 @info{qw(debug transcript)};
743 my @data = @{$info{data}};
744 my @bugs = @{$info{bugs}};
747 for my $data (@data) {
748 if (not defined $data->{severity}) {
749 $data->{severity} = $param{severity};
750 $action = "Severity set to '$param{severity}'\n";
753 if ($data->{severity} eq '') {
754 $data->{severity} = $config{default_severity};
756 if ($data->{severity} eq $param{severity}) {
757 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
760 $action = "Severity set to '$param{severity}' from '$data->{severity}'\n";
761 $data->{severity} = $param{severity};
763 append_action_to_log(bug => $data->{bug_num},
765 __return_append_to_log_options(
770 if not exists $param{append_log} or $param{append_log};
771 writebug($data->{bug_num},$data);
772 print {$transcript} "$action\n";
774 __end_control(%info);
782 transcript => $transcript,
783 ($dl > 0 ? (debug => $transcript):()),
784 requester => $header{from},
785 request_addr => $controlrequestaddr,
787 affected_packages => \%affected_packages,
788 recipients => \%recipients,
794 print {$transcript} "Failed to set foo $ref bar: $@";
802 my %param = validate_with(params => \@_,
803 spec => {bug => {type => SCALAR,
806 # specific options here
807 submitter => {type => SCALAR|UNDEF,
811 %append_action_options,
815 $param{submitter} = undef if defined $param{submitter} and
816 not length $param{submitter};
818 if (defined $param{submitter} and
819 not Mail::RFC822::Address::valid($param{submitter})) {
820 die "New submitter address $param{submitter} is not a valid e-mail address";
824 __begin_control(%param,
827 my ($debug,$transcript) =
828 @info{qw(debug transcript)};
829 my @data = @{$info{data}};
830 my @bugs = @{$info{bugs}};
833 my $warn_fixed = 1; # avoid warning multiple times if there are
835 my @change_submitter = ();
836 my @bugs_to_reopen = ();
837 for my $data (@data) {
838 if (not exists $data->{done} or
839 not defined $data->{done} or
840 not length $data->{done}) {
841 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
842 __end_control(%info);
845 if (@{$data->{fixed_versions}} and $warn_fixed) {
846 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
847 print {$transcript} "you may need to use 'found' to remove fixed versions.\n";
850 if (defined $param{submitter} and length $param{submitter}
851 and $data->{originator} ne $param{submitter}) {
852 push @change_submitter,$data->{bug_num};
855 __end_control(%info);
856 my @params_for_subcalls =
857 map {exists $param{$_}?($_,$param{$_}):()}
858 (keys %common_options,
859 keys %append_action_options,
862 for my $bug (@change_submitter) {
863 set_submitter(bug=>$bug,
864 submitter => $param{submitter},
865 @params_for_subcalls,
868 set_fixed(fixed => [],
878 set_submitter(bug => $ref,
879 transcript => $transcript,
880 ($dl > 0 ? (debug => $transcript):()),
881 requester => $header{from},
882 request_addr => $controlrequestaddr,
884 affected_packages => \%affected_packages,
885 recipients => \%recipients,
886 submitter => $new_submitter,
887 notify_submitter => 1,
892 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
895 Sets the submitter of a bug. If notify_submitter is true (the
896 default), notifies the old submitter of a bug on changes
901 my %param = validate_with(params => \@_,
902 spec => {bug => {type => SCALAR,
905 # specific options here
906 submitter => {type => SCALAR,
908 notify_submitter => {type => BOOLEAN,
912 %append_action_options,
915 if (not Mail::RFC822::Address::valid($param{submitter})) {
916 die "New submitter address $param{submitter} is not a valid e-mail address";
919 __begin_control(%param,
920 command => 'submitter'
922 my ($debug,$transcript) =
923 @info{qw(debug transcript)};
924 my @data = @{$info{data}};
925 my @bugs = @{$info{bugs}};
927 # here we only concern ourselves with the first of the merged bugs
928 for my $data ($data[0]) {
929 my $notify_old_submitter = 0;
930 my $old_data = dclone($data);
931 print {$debug} "Going to change bug submitter\n";
932 if (((not defined $param{submitter} or not length $param{submitter}) and
933 (not defined $data->{originator} or not length $data->{originator})) or
934 (defined $param{submitter} and defined $data->{originator} and
935 $param{submitter} eq $data->{originator})) {
936 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
937 unless __internal_request();
941 if (defined $data->{originator} and length($data->{originator})) {
942 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
943 $notify_old_submitter = 1;
946 $action= "Set $config{bug} submitter to '$param{submitter}'.";
948 $data->{originator} = $param{submitter};
950 append_action_to_log(bug => $data->{bug_num},
951 command => 'submitter',
953 old_data => $old_data,
955 __return_append_to_log_options(
960 if not exists $param{append_log} or $param{append_log};
961 writebug($data->{bug_num},$data);
962 print {$transcript} "$action\n";
963 # notify old submitter
964 if ($notify_old_submitter and $param{notify_submitter}) {
965 send_mail_message(message =>
966 create_mime_message([default_headers(queue_file => $param{request_nn},
968 msgid => $param{request_msgid},
970 pr_msg => 'submitter-changed',
972 [To => $old_data->{submitter},
973 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
977 __message_body_template('mail/submitter_changed',
978 {old_data => $old_data,
980 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
984 recipients => $old_data->{submitter},
988 __end_control(%info);
996 set_forwarded(bug => $ref,
997 transcript => $transcript,
998 ($dl > 0 ? (debug => $transcript):()),
999 requester => $header{from},
1000 request_addr => $controlrequestaddr,
1002 affected_packages => \%affected_packages,
1003 recipients => \%recipients,
1004 forwarded => $forward_to,
1009 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1012 Sets the location to which a bug is forwarded. Given an undef
1013 forwarded, unsets forwarded.
1019 my %param = validate_with(params => \@_,
1020 spec => {bug => {type => SCALAR,
1023 # specific options here
1024 forwarded => {type => SCALAR|UNDEF,
1027 %append_action_options,
1030 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1031 die "Non-printable characters are not allowed in the forwarded field";
1034 __begin_control(%param,
1035 command => 'forwarded'
1037 my ($debug,$transcript) =
1038 @info{qw(debug transcript)};
1039 my @data = @{$info{data}};
1040 my @bugs = @{$info{bugs}};
1042 for my $data (@data) {
1043 my $old_data = dclone($data);
1044 print {$debug} "Going to change bug forwarded\n";
1045 if (((not defined $param{forwarded} or not length $param{forwarded}) and
1046 (not defined $data->{forwarded} or not length $data->{forwarded})) or
1047 $param{forwarded} eq $data->{forwarded}) {
1048 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1049 unless __internal_request();
1053 if (not defined $param{forwarded}) {
1054 $action= "Unset $config{bug} forwarded-to-address";
1056 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1057 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1060 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1062 $data->{forwarded} = $param{forwarded};
1064 append_action_to_log(bug => $data->{bug_num},
1065 command => 'forwarded',
1067 old_data => $old_data,
1069 __return_append_to_log_options(
1074 if not exists $param{append_log} or $param{append_log};
1075 writebug($data->{bug_num},$data);
1076 print {$transcript} "$action\n";
1078 __end_control(%info);
1087 set_title(bug => $ref,
1088 transcript => $transcript,
1089 ($dl > 0 ? (debug => $transcript):()),
1090 requester => $header{from},
1091 request_addr => $controlrequestaddr,
1093 affected_packages => \%affected_packages,
1094 recipients => \%recipients,
1095 title => $new_title,
1100 print {$transcript} "Failed to set the title of $ref: $@";
1103 Sets the title of a specific bug
1109 my %param = validate_with(params => \@_,
1110 spec => {bug => {type => SCALAR,
1113 # specific options here
1114 title => {type => SCALAR,
1117 %append_action_options,
1120 if ($param{title} =~ /[^[:print:]]/) {
1121 die "Non-printable characters are not allowed in bug titles";
1124 my %info = __begin_control(%param,
1127 my ($debug,$transcript) =
1128 @info{qw(debug transcript)};
1129 my @data = @{$info{data}};
1130 my @bugs = @{$info{bugs}};
1132 for my $data (@data) {
1133 my $old_data = dclone($data);
1134 print {$debug} "Going to change bug title\n";
1135 if (defined $data->{subject} and length($data->{subject}) and
1136 $data->{subject} eq $param{title}) {
1137 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1138 unless __internal_request();
1142 if (defined $data->{subject} and length($data->{subject})) {
1143 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1145 $action= "Set $config{bug} title to '$param{title}'.";
1147 $data->{subject} = $param{title};
1149 append_action_to_log(bug => $data->{bug_num},
1152 old_data => $old_data,
1154 __return_append_to_log_options(
1159 if not exists $param{append_log} or $param{append_log};
1160 writebug($data->{bug_num},$data);
1161 print {$transcript} "$action\n";
1163 __end_control(%info);
1170 set_package(bug => $ref,
1171 transcript => $transcript,
1172 ($dl > 0 ? (debug => $transcript):()),
1173 requester => $header{from},
1174 request_addr => $controlrequestaddr,
1176 affected_packages => \%affected_packages,
1177 recipients => \%recipients,
1178 package => $new_package,
1184 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1187 Indicates that a bug is in a particular package. If is_source is true,
1188 indicates that the package is a source package. [Internally, this
1189 causes src: to be prepended to the package name.]
1191 The default for is_source is 0. As a special case, if the package
1192 starts with 'src:', it is assumed to be a source package and is_source
1195 The package option must match the package_name_re regex.
1200 my %param = validate_with(params => \@_,
1201 spec => {bug => {type => SCALAR,
1204 # specific options here
1205 package => {type => SCALAR|ARRAYREF,
1207 is_source => {type => BOOLEAN,
1211 %append_action_options,
1214 my @new_packages = map {splitpackages($_)} make_list($param{package});
1215 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1216 croak "Invalid package name '".
1217 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1220 my %info = __begin_control(%param,
1221 command => 'package',
1223 my ($debug,$transcript) =
1224 @info{qw(debug transcript)};
1225 my @data = @{$info{data}};
1226 my @bugs = @{$info{bugs}};
1227 # clean up the new package
1231 ($temp =~ s/^src:// or
1232 $param{is_source}) ? 'src:'.$temp:$temp;
1236 my $package_reassigned = 0;
1237 for my $data (@data) {
1238 my $old_data = dclone($data);
1239 print {$debug} "Going to change assigned package\n";
1240 if (defined $data->{package} and length($data->{package}) and
1241 $data->{package} eq $new_package) {
1242 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1243 unless __internal_request();
1247 if (defined $data->{package} and length($data->{package})) {
1248 $package_reassigned = 1;
1249 $action= "$config{bug} reassigned from package '$data->{package}'".
1250 " to '$new_package'.";
1252 $action= "$config{bug} assigned to package '$new_package'.";
1254 $data->{package} = $new_package;
1256 append_action_to_log(bug => $data->{bug_num},
1257 command => 'package',
1259 old_data => $old_data,
1261 __return_append_to_log_options(
1266 if not exists $param{append_log} or $param{append_log};
1267 writebug($data->{bug_num},$data);
1268 print {$transcript} "$action\n";
1270 __end_control(%info);
1271 # Only clear the fixed/found versions if the package has been
1273 if ($package_reassigned) {
1274 my @params_for_found_fixed =
1275 map {exists $param{$_}?($_,$param{$_}):()}
1277 keys %common_options,
1278 keys %append_action_options,
1280 set_found(found => [],
1281 @params_for_found_fixed,
1283 set_fixed(fixed => [],
1284 @params_for_found_fixed,
1292 set_found(bug => $ref,
1293 transcript => $transcript,
1294 ($dl > 0 ? (debug => $transcript):()),
1295 requester => $header{from},
1296 request_addr => $controlrequestaddr,
1298 affected_packages => \%affected_packages,
1299 recipients => \%recipients,
1306 print {$transcript} "Failed to set found on $ref: $@";
1310 Sets, adds, or removes the specified found versions of a package
1312 If the version list is empty, and the bug is currently not "done",
1313 causes the done field to be cleared.
1315 If any of the versions added to found are greater than any version in
1316 which the bug is fixed (or when the bug is found and there are no
1317 fixed versions) the done field is cleared.
1322 my %param = validate_with(params => \@_,
1323 spec => {bug => {type => SCALAR,
1326 # specific options here
1327 found => {type => SCALAR|ARRAYREF,
1330 add => {type => BOOLEAN,
1333 remove => {type => BOOLEAN,
1337 %append_action_options,
1340 if ($param{add} and $param{remove}) {
1341 croak "It's nonsensical to add and remove the same versions";
1345 __begin_control(%param,
1348 my ($debug,$transcript) =
1349 @info{qw(debug transcript)};
1350 my @data = @{$info{data}};
1351 my @bugs = @{$info{bugs}};
1353 for my $version (make_list($param{found})) {
1354 next unless defined $version;
1355 $versions{$version} =
1356 [make_source_versions(package => [splitpackages($data[0]{package})],
1357 warnings => $transcript,
1360 versions => $version,
1363 # This is really ugly, but it's what we have to do
1364 if (not @{$versions{$version}}) {
1365 print {$transcript} "Unable to make a source version for version '$version'\n";
1368 if (not keys %versions and ($param{remove} or $param{add})) {
1369 if ($param{remove}) {
1370 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1373 print {$transcript} "Requested to add no versions; doing nothing.\n";
1375 __end_control(%info);
1378 # first things first, make the versions fully qualified source
1380 for my $data (@data) {
1381 # The 'done' field gets a bit weird with version tracking,
1382 # because a bug may be closed by multiple people in different
1383 # branches. Until we have something more flexible, we set it
1384 # every time a bug is fixed, and clear it when a bug is found
1385 # in a version greater than any version in which the bug is
1386 # fixed or when a bug is found and there is no fixed version
1387 my $action = 'Did not alter found versions';
1388 my %found_added = ();
1389 my %found_removed = ();
1390 my %fixed_removed = ();
1392 my $old_data = dclone($data);
1393 if (not $param{add} and not $param{remove}) {
1394 $found_removed{$_} = 1 for @{$data->{found_versions}};
1395 $data->{found_versions} = [];
1398 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1400 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1401 for my $version (keys %versions) {
1403 my @svers = @{$versions{$version}};
1407 for my $sver (@svers) {
1408 if (not exists $found_versions{$sver}) {
1409 $found_versions{$sver} = 1;
1410 $found_added{$sver} = 1;
1412 # if the found we are adding matches any fixed
1413 # versions, remove them
1414 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1415 delete $fixed_versions{$_} for @temp;
1416 $fixed_removed{$_} = 1 for @temp;
1419 # We only care about reopening the bug if the bug is
1421 if (defined $data->{done} and length $data->{done}) {
1422 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1423 map {m{([^/]+)$}; $1;} @svers;
1424 # determine if we need to reopen
1425 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1426 map {m{([^/]+)$}; $1;} keys %fixed_versions;
1427 if (not @fixed_order or
1428 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1434 elsif ($param{remove}) {
1435 # in the case of removal, we only concern ourself with
1436 # the version passed, not the source version it maps
1438 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1439 delete $found_versions{$_} for @temp;
1440 $found_removed{$_} = 1 for @temp;
1443 # set the keys to exactly these values
1444 my @svers = @{$versions{$version}};
1448 for my $sver (@svers) {
1449 if (not exists $found_versions{$sver}) {
1450 $found_versions{$sver} = 1;
1451 if (exists $found_removed{$sver}) {
1452 delete $found_removed{$sver};
1455 $found_added{$sver} = 1;
1462 $data->{found_versions} = [keys %found_versions];
1463 $data->{fixed_versions} = [keys %fixed_versions];
1466 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1467 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1468 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1469 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1470 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1472 $action .= " and reopened"
1474 if (not $reopened and not @changed) {
1475 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1476 unless __internal_request();
1480 append_action_to_log(bug => $data->{bug_num},
1483 old_data => $old_data,
1485 __return_append_to_log_options(
1490 if not exists $param{append_log} or $param{append_log};
1491 writebug($data->{bug_num},$data);
1492 print {$transcript} "$action\n";
1494 __end_control(%info);
1500 set_fixed(bug => $ref,
1501 transcript => $transcript,
1502 ($dl > 0 ? (debug => $transcript):()),
1503 requester => $header{from},
1504 request_addr => $controlrequestaddr,
1506 affected_packages => \%affected_packages,
1507 recipients => \%recipients,
1515 print {$transcript} "Failed to set fixed on $ref: $@";
1519 Sets, adds, or removes the specified fixed versions of a package
1521 If the fixed versions are empty (or end up being empty after this
1522 call) or the greatest fixed version is less than the greatest found
1523 version and the reopen option is true, the bug is reopened.
1525 This function is also called by the reopen function, which causes all
1526 of the fixed versions to be cleared.
1531 my %param = validate_with(params => \@_,
1532 spec => {bug => {type => SCALAR,
1535 # specific options here
1536 fixed => {type => SCALAR|ARRAYREF,
1539 add => {type => BOOLEAN,
1542 remove => {type => BOOLEAN,
1545 reopen => {type => BOOLEAN,
1549 %append_action_options,
1552 if ($param{add} and $param{remove}) {
1553 croak "It's nonsensical to add and remove the same versions";
1556 __begin_control(%param,
1559 my ($debug,$transcript) =
1560 @info{qw(debug transcript)};
1561 my @data = @{$info{data}};
1562 my @bugs = @{$info{bugs}};
1564 for my $version (make_list($param{fixed})) {
1565 next unless defined $version;
1566 $versions{$version} =
1567 [make_source_versions(package => [splitpackages($data[0]{package})],
1568 warnings => $transcript,
1571 versions => $version,
1574 # This is really ugly, but it's what we have to do
1575 if (not @{$versions{$version}}) {
1576 print {$transcript} "Unable to make a source version for version '$version'\n";
1579 if (not keys %versions and ($param{remove} or $param{add})) {
1580 if ($param{remove}) {
1581 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1584 print {$transcript} "Requested to add no versions; doing nothing.\n";
1586 __end_control(%info);
1589 # first things first, make the versions fully qualified source
1591 for my $data (@data) {
1592 my $old_data = dclone($data);
1593 # The 'done' field gets a bit weird with version tracking,
1594 # because a bug may be closed by multiple people in different
1595 # branches. Until we have something more flexible, we set it
1596 # every time a bug is fixed, and clear it when a bug is found
1597 # in a version greater than any version in which the bug is
1598 # fixed or when a bug is found and there is no fixed version
1599 my $action = 'Did not alter fixed versions';
1600 my %found_added = ();
1601 my %found_removed = ();
1602 my %fixed_added = ();
1603 my %fixed_removed = ();
1605 if (not $param{add} and not $param{remove}) {
1606 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1607 $data->{fixed_versions} = [];
1610 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1612 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1613 for my $version (keys %versions) {
1615 my @svers = @{$versions{$version}};
1619 for my $sver (@svers) {
1620 if (not exists $fixed_versions{$sver}) {
1621 $fixed_versions{$sver} = 1;
1622 $fixed_added{$sver} = 1;
1626 elsif ($param{remove}) {
1627 # in the case of removal, we only concern ourself with
1628 # the version passed, not the source version it maps
1630 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1631 delete $fixed_versions{$_} for @temp;
1632 $fixed_removed{$_} = 1 for @temp;
1635 # set the keys to exactly these values
1636 my @svers = @{$versions{$version}};
1640 for my $sver (@svers) {
1641 if (not exists $fixed_versions{$sver}) {
1642 $fixed_versions{$sver} = 1;
1643 if (exists $fixed_removed{$sver}) {
1644 delete $fixed_removed{$sver};
1647 $fixed_added{$sver} = 1;
1654 $data->{found_versions} = [keys %found_versions];
1655 $data->{fixed_versions} = [keys %fixed_versions];
1657 # If we're supposed to consider reopening, reopen if the
1658 # fixed versions are empty or the greatest found version
1659 # is greater than the greatest fixed version
1660 if ($param{reopen} and defined $data->{done}
1661 and length $data->{done}) {
1662 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1663 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1664 # determine if we need to reopen
1665 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1666 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1667 if (not @fixed_order or
1668 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1675 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1676 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1677 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1678 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1679 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1681 $action .= " and reopened"
1683 if (not $reopened and not @changed) {
1684 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1685 unless __internal_request();
1689 append_action_to_log(bug => $data->{bug_num},
1692 old_data => $old_data,
1694 __return_append_to_log_options(
1699 if not exists $param{append_log} or $param{append_log};
1700 writebug($data->{bug_num},$data);
1701 print {$transcript} "$action\n";
1703 __end_control(%info);
1711 affects(bug => $ref,
1712 transcript => $transcript,
1713 ($dl > 0 ? (debug => $transcript):()),
1714 requester => $header{from},
1715 request_addr => $controlrequestaddr,
1717 affected_packages => \%affected_packages,
1718 recipients => \%recipients,
1726 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
1729 This marks a bug as affecting packages which the bug is not actually
1730 in. This should only be used in cases where fixing the bug instantly
1731 resolves the problem in the other packages.
1733 By default, the packages are set to the list of packages passed.
1734 However, if you pass add => 1 or remove => 1, the list of packages
1735 passed are added or removed from the affects list, respectively.
1740 my %param = validate_with(params => \@_,
1741 spec => {bug => {type => SCALAR,
1744 # specific options here
1745 packages => {type => SCALAR|ARRAYREF,
1748 add => {type => BOOLEAN,
1751 remove => {type => BOOLEAN,
1755 %append_action_options,
1758 if ($param{add} and $param{remove}) {
1759 croak "Asking to both add and remove affects is nonsensical";
1762 __begin_control(%param,
1763 command => 'affects'
1765 my ($debug,$transcript) =
1766 @info{qw(debug transcript)};
1767 my @data = @{$info{data}};
1768 my @bugs = @{$info{bugs}};
1770 for my $data (@data) {
1772 print {$debug} "Going to change affects\n";
1773 my @packages = splitpackages($data->{affects});
1775 @packages{@packages} = (1) x @packages;
1778 for my $package (make_list($param{packages})) {
1779 next unless defined $package and length $package;
1780 if (not $packages{$package}) {
1781 $packages{$package} = 1;
1782 push @added,$package;
1786 $action = "Added indication that $data->{bug_num} affects ".
1787 english_join(\@added);
1790 elsif ($param{remove}) {
1792 for my $package (make_list($param{packages})) {
1793 if ($packages{$package}) {
1794 next unless defined $package and length $package;
1795 delete $packages{$package};
1796 push @removed,$package;
1799 $action = "Removed indication that $data->{bug_num} affects " .
1800 english_join(\@removed);
1803 my %added_packages = ();
1804 my %removed_packages = %packages;
1806 for my $package (make_list($param{packages})) {
1807 next unless defined $package and length $package;
1808 $packages{$package} = 1;
1809 delete $removed_packages{$package};
1810 $added_packages{$package} = 1;
1812 if (keys %removed_packages) {
1813 $action = "Removed indication that $data->{bug_num} affects ".
1814 english_join([keys %removed_packages]);
1815 $action .= "\n" if keys %added_packages;
1817 if (keys %added_packages) {
1818 $action .= "Added indication that $data->{bug_num} affects " .
1819 english_join([%added_packages]);
1822 if (not length $action) {
1823 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
1824 unless __internal_request();
1826 my $old_data = dclone($data);
1827 $data->{affects} = join(',',keys %packages);
1828 append_action_to_log(bug => $data->{bug_num},
1830 command => 'affects',
1832 old_data => $old_data,
1833 __return_append_to_log_options(
1838 if not exists $param{append_log} or $param{append_log};
1839 writebug($data->{bug_num},$data);
1840 print {$transcript} "$action\n";
1842 __end_control(%info);
1846 =head1 SUMMARY FUNCTIONS
1851 summary(bug => $ref,
1852 transcript => $transcript,
1853 ($dl > 0 ? (debug => $transcript):()),
1854 requester => $header{from},
1855 request_addr => $controlrequestaddr,
1857 affected_packages => \%affected_packages,
1858 recipients => \%recipients,
1864 print {$transcript} "Failed to mark $ref with summary foo: $@";
1867 Handles all setting of summary fields
1869 If summary is undef, unsets the summary
1871 If summary is 0, sets the summary to the first paragraph contained in
1874 If summary is numeric, sets the summary to the message specified.
1881 my %param = validate_with(params => \@_,
1882 spec => {bug => {type => SCALAR,
1885 # specific options here
1886 summary => {type => SCALAR|UNDEF,
1890 %append_action_options,
1893 croak "summary must be numeric or undef" if
1894 defined $param{summary} and not $param{summary} =~ /^\d+$/;
1896 __begin_control(%param,
1897 command => 'summary'
1899 my ($debug,$transcript) =
1900 @info{qw(debug transcript)};
1901 my @data = @{$info{data}};
1902 my @bugs = @{$info{bugs}};
1903 # figure out the log that we're going to use
1905 my $summary_msg = '';
1907 if (not defined $param{summary}) {
1909 print {$debug} "Removing summary fields\n";
1910 $action = 'Removed summary';
1914 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
1915 if ($param{summary} == 0) {
1916 $log = $param{message};
1917 $summary_msg = @records + 1;
1920 if (($param{summary} - 1 ) > $#records) {
1921 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
1923 my $record = $records[($param{summary} - 1 )];
1924 if ($record->{type} !~ /incoming-recv|recips/) {
1925 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
1927 $summary_msg = $param{summary};
1928 $log = [$record->{text}];
1930 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
1931 my $body = $p_o->{body};
1932 my $in_pseudoheaders = 0;
1934 # walk through body until we get non-blank lines
1935 for my $line (@{$body}) {
1936 if ($line =~ /^\s*$/) {
1937 if (length $paragraph) {
1938 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
1944 $in_pseudoheaders = 0;
1947 # skip a paragraph if it looks like it's control or
1949 if ($line =~ m{^\s*(?:(?:Package|Source|Version)\:| #pseudo headers
1950 (?:package|(?:no|)owner|severity|tag|summary| #control
1951 reopen|close|(?:not|)(?:fixed|found)|clone|
1952 (?:force|)merge|user(?:category|tag|)
1955 if (not length $paragraph) {
1956 print {$debug} "Found control/pseudo-headers and skiping them\n";
1957 $in_pseudoheaders = 1;
1961 next if $in_pseudoheaders;
1962 $paragraph .= $line ." \n";
1964 print {$debug} "Summary is going to be '$paragraph'\n";
1965 $summary = $paragraph;
1966 $summary =~ s/[\n\r]/ /g;
1967 if (not length $summary) {
1968 die "Unable to find summary message to use";
1970 # trim off a trailing spaces
1971 $summary =~ s/\ *$//;
1973 for my $data (@data) {
1974 print {$debug} "Going to change summary\n";
1975 if (((not defined $summary or not length $summary) and
1976 (not defined $data->{summary} or not length $data->{summary})) or
1977 $summary eq $data->{summary}) {
1978 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1979 unless __internal_request();
1982 if (length $summary) {
1983 if (length $data->{summary}) {
1984 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1987 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1990 my $old_data = dclone($data);
1991 $data->{summary} = $summary;
1992 append_action_to_log(bug => $data->{bug_num},
1993 command => 'summary',
1994 old_data => $old_data,
1997 __return_append_to_log_options(
2002 if not exists $param{append_log} or $param{append_log};
2003 writebug($data->{bug_num},$data);
2004 print {$transcript} "$action\n";
2006 __end_control(%info);
2012 =head1 OWNER FUNCTIONS
2018 transcript => $transcript,
2019 ($dl > 0 ? (debug => $transcript):()),
2020 requester => $header{from},
2021 request_addr => $controlrequestaddr,
2023 recipients => \%recipients,
2029 print {$transcript} "Failed to mark $ref as having an owner: $@";
2032 Handles all setting of the owner field; given an owner of undef or of
2033 no length, indicates that a bug is not owned by anyone.
2038 my %param = validate_with(params => \@_,
2039 spec => {bug => {type => SCALAR,
2042 owner => {type => SCALAR|UNDEF,
2045 %append_action_options,
2049 __begin_control(%param,
2052 my ($debug,$transcript) =
2053 @info{qw(debug transcript)};
2054 my @data = @{$info{data}};
2055 my @bugs = @{$info{bugs}};
2057 for my $data (@data) {
2058 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2059 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2060 if (not defined $param{owner} or not length $param{owner}) {
2061 if (not defined $data->{owner} or not length $data->{owner}) {
2062 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2063 unless __internal_request();
2067 $action = "Removed annotation that $config{bug} was owned by " .
2071 if ($data->{owner} eq $param{owner}) {
2072 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2075 if (length $data->{owner}) {
2076 $action = "Owner changed from $data->{owner} to $param{owner}.";
2079 $action = "Owner recorded as $param{owner}."
2082 my $old_data = dclone($data);
2083 $data->{owner} = $param{owner};
2084 append_action_to_log(bug => $data->{bug_num},
2087 old_data => $old_data,
2089 __return_append_to_log_options(
2094 if not exists $param{append_log} or $param{append_log};
2095 writebug($data->{bug_num},$data);
2096 print {$transcript} "$action\n";
2098 __end_control(%info);
2102 =head1 ARCHIVE FUNCTIONS
2109 bug_archive(bug => $bug_num,
2111 transcript => \$transcript,
2116 transcript("Unable to archive $bug_num\n");
2119 transcript($transcript);
2122 This routine archives a bug
2126 =item bug -- bug number
2128 =item check_archiveable -- check wether a bug is archiveable before
2129 archiving; defaults to 1
2131 =item archive_unarchived -- whether to archive bugs which have not
2132 previously been archived; defaults to 1. [Set to 0 when used from
2135 =item ignore_time -- whether to ignore time constraints when archiving
2136 a bug; defaults to 0.
2143 my %param = validate_with(params => \@_,
2144 spec => {bug => {type => SCALAR,
2147 check_archiveable => {type => BOOLEAN,
2150 archive_unarchived => {type => BOOLEAN,
2153 ignore_time => {type => BOOLEAN,
2157 %append_action_options,
2160 my %info = __begin_control(%param,
2161 command => 'archive',
2163 my ($debug,$transcript) = @info{qw(debug transcript)};
2164 my @data = @{$info{data}};
2165 my @bugs = @{$info{bugs}};
2166 my $action = "$config{bug} archived.";
2167 if ($param{check_archiveable} and
2168 not bug_archiveable(bug=>$param{bug},
2169 ignore_time => $param{ignore_time},
2171 print {$transcript} "Bug $param{bug} cannot be archived\n";
2172 die "Bug $param{bug} cannot be archived";
2174 print {$debug} "$param{bug} considering\n";
2175 if (not $param{archive_unarchived} and
2176 not exists $data[0]{unarchived}
2178 print {$transcript} "$param{bug} has not been archived previously\n";
2179 die "$param{bug} has not been archived previously";
2181 add_recipients(recipients => $param{recipients},
2184 transcript => $transcript,
2186 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2187 for my $bug (@bugs) {
2188 if ($param{check_archiveable}) {
2189 die "Bug $bug cannot be archived (but $param{bug} can?)"
2190 unless bug_archiveable(bug=>$bug,
2191 ignore_time => $param{ignore_time},
2195 # If we get here, we can archive/remove this bug
2196 print {$debug} "$param{bug} removing\n";
2197 for my $bug (@bugs) {
2198 #print "$param{bug} removing $bug\n" if $debug;
2199 my $dir = get_hashname($bug);
2200 # First indicate that this bug is being archived
2201 append_action_to_log(bug => $bug,
2203 command => 'archive',
2204 # we didn't actually change the data
2205 # when we archived, so we don't pass
2206 # a real new_data or old_data
2209 __return_append_to_log_options(
2214 if not exists $param{append_log} or $param{append_log};
2215 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2216 if ($config{save_old_bugs}) {
2217 mkpath("$config{spool_dir}/archive/$dir");
2218 foreach my $file (@files_to_remove) {
2219 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2220 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2221 # we need to bail out here if things have
2222 # gone horribly wrong to avoid removing a
2224 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2227 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2229 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2230 print {$transcript} "deleted $bug (from $param{bug})\n";
2232 bughook_archive(@bugs);
2233 __end_control(%info);
2236 =head2 bug_unarchive
2240 bug_unarchive(bug => $bug_num,
2242 transcript => \$transcript,
2247 transcript("Unable to archive bug: $bug_num");
2249 transcript($transcript);
2251 This routine unarchives a bug
2256 my %param = validate_with(params => \@_,
2257 spec => {bug => {type => SCALAR,
2261 %append_action_options,
2265 my %info = __begin_control(%param,
2267 command=>'unarchive');
2268 my ($debug,$transcript) =
2269 @info{qw(debug transcript)};
2270 my @data = @{$info{data}};
2271 my @bugs = @{$info{bugs}};
2272 my $action = "$config{bug} unarchived.";
2273 my @files_to_remove;
2274 for my $bug (@bugs) {
2275 print {$debug} "$param{bug} removing $bug\n";
2276 my $dir = get_hashname($bug);
2277 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
2278 mkpath("archive/$dir");
2279 foreach my $file (@files_to_copy) {
2280 # die'ing here sucks
2281 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2282 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2283 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
2285 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
2286 print {$transcript} "Unarchived $config{bug} $bug\n";
2288 unlink(@files_to_remove) or die "Unable to unlink bugs";
2289 # Indicate that this bug has been archived previously
2290 for my $bug (@bugs) {
2291 my $newdata = readbug($bug);
2292 my $old_data = dclone($newdata);
2293 if (not defined $newdata) {
2294 print {$transcript} "$config{bug} $bug disappeared!\n";
2295 die "Bug $bug disappeared!";
2297 $newdata->{unarchived} = time;
2298 append_action_to_log(bug => $bug,
2300 command => 'unarchive',
2301 new_data => $newdata,
2302 old_data => $old_data,
2303 __return_append_to_log_options(
2308 if not exists $param{append_log} or $param{append_log};
2309 writebug($bug,$newdata);
2311 __end_control(%info);
2314 =head2 append_action_to_log
2316 append_action_to_log
2318 This should probably be moved to Debbugs::Log; have to think that out
2323 sub append_action_to_log{
2324 my %param = validate_with(params => \@_,
2325 spec => {bug => {type => SCALAR,
2328 new_data => {type => HASHREF,
2331 old_data => {type => HASHREF,
2334 command => {type => SCALAR,
2337 action => {type => SCALAR,
2339 requester => {type => SCALAR,
2342 request_addr => {type => SCALAR,
2345 location => {type => SCALAR,
2348 message => {type => SCALAR|ARRAYREF,
2351 desc => {type => SCALAR,
2354 get_lock => {type => BOOLEAN,
2358 # append_action_options here
2359 # because some of these
2360 # options aren't actually
2361 # optional, even though the
2362 # original function doesn't
2366 # Fix this to use $param{location}
2367 my $log_location = buglog($param{bug});
2368 die "Unable to find .log for $param{bug}"
2369 if not defined $log_location;
2370 if ($param{get_lock}) {
2371 filelock("lock/$param{bug}");
2373 my $log = IO::File->new(">>$log_location") or
2374 die "Unable to open $log_location for appending: $!";
2375 # determine difference between old and new
2377 if (exists $param{old_data} and exists $param{new_data}) {
2378 my $old_data = dclone($param{old_data});
2379 my $new_data = dclone($param{new_data});
2380 for my $key (keys %{$old_data}) {
2381 if (not exists $Debbugs::Status::fields{$key}) {
2382 delete $old_data->{$key};
2385 next unless exists $new_data->{$key};
2386 next unless defined $new_data->{$key};
2387 if (not defined $old_data->{$key}) {
2388 delete $old_data->{$key};
2391 if (ref($new_data->{$key}) and
2392 ref($old_data->{$key}) and
2393 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2394 local $Storable::canonical = 1;
2395 # print STDERR Dumper($new_data,$old_data,$key);
2396 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2397 delete $new_data->{$key};
2398 delete $old_data->{$key};
2401 elsif ($new_data->{$key} eq $old_data->{$key}) {
2402 delete $new_data->{$key};
2403 delete $old_data->{$key};
2406 for my $key (keys %{$new_data}) {
2407 if (not exists $Debbugs::Status::fields{$key}) {
2408 delete $new_data->{$key};
2411 next unless exists $old_data->{$key};
2412 next unless defined $old_data->{$key};
2413 if (not defined $new_data->{$key} or
2414 not exists $Debbugs::Status::fields{$key}) {
2415 delete $new_data->{$key};
2418 if (ref($new_data->{$key}) and
2419 ref($old_data->{$key}) and
2420 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2421 local $Storable::canonical = 1;
2422 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2423 delete $new_data->{$key};
2424 delete $old_data->{$key};
2427 elsif ($new_data->{$key} eq $old_data->{$key}) {
2428 delete $new_data->{$key};
2429 delete $old_data->{$key};
2432 $data_diff .= "<!-- new_data:\n";
2434 for my $key (keys %{$new_data}) {
2435 if (not exists $Debbugs::Status::fields{$key}) {
2436 warn "No such field $key";
2439 $nd{$key} = $new_data->{$key};
2440 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
2442 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
2443 $data_diff .= "-->\n";
2444 $data_diff .= "<!-- old_data:\n";
2446 for my $key (keys %{$old_data}) {
2447 if (not exists $Debbugs::Status::fields{$key}) {
2448 warn "No such field $key";
2451 $od{$key} = $old_data->{$key};
2452 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
2454 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
2455 $data_diff .= "-->\n";
2457 my $msg = join('',"\6\n",
2458 (exists $param{command} ?
2459 "<!-- command:".html_escape($param{command})." -->\n":""
2461 (length $param{requester} ?
2462 "<!-- requester: ".html_escape($param{requester})." -->\n":""
2464 (length $param{request_addr} ?
2465 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
2467 "<!-- time:".time()." -->\n",
2469 "<strong>".html_escape($param{action})."</strong>\n");
2470 if (length $param{requester}) {
2471 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
2473 if (length $param{request_addr}) {
2474 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
2476 if (length $param{desc}) {
2477 $msg .= ":<br>\n$param{desc}\n";
2483 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
2484 $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
2485 or die "Unable to append to $log_location: $!";
2487 print {$log} $msg or die "Unable to append to $log_location: $!";
2488 close $log or die "Unable to close $log_location: $!";
2489 if ($param{get_lock}) {
2497 =head1 PRIVATE FUNCTIONS
2499 =head2 __handle_affected_packages
2501 __handle_affected_packages(affected_packages => {},
2509 sub __handle_affected_packages{
2510 my %param = validate_with(params => \@_,
2511 spec => {%common_options,
2512 data => {type => ARRAYREF|HASHREF
2517 for my $data (make_list($param{data})) {
2518 next unless exists $data->{package} and defined $data->{package};
2519 my @packages = split /\s*,\s*/,$data->{package};
2520 @{$param{affected_packages}}{@packages} = (1) x @packages;
2524 =head2 __handle_debug_transcript
2526 my ($debug,$transcript) = __handle_debug_transcript(%param);
2528 Returns a debug and transcript filehandle
2533 sub __handle_debug_transcript{
2534 my %param = validate_with(params => \@_,
2535 spec => {%common_options},
2538 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
2539 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
2540 return ($debug,$transcript);
2547 Produces a small bit of bug information to kick out to the transcript
2554 next unless defined $data and exists $data->{bug_num};
2555 $return .= "Bug #".($data->{bug_num}||'').
2556 ((defined $data->{done} and length $data->{done})?
2557 " {Done: $data->{done}}":''
2559 " [".($data->{package}||'(no package)'). "] ".
2560 ($data->{subject}||'(no subject)')."\n";
2566 =head2 __internal_request
2568 __internal_request()
2569 __internal_request($level)
2571 Returns true if the caller of the function calling __internal_request
2572 belongs to __PACKAGE__
2574 This allows us to be magical, and don't bother to print bug info if
2575 the second caller is from this package, amongst other things.
2577 An optional level is allowed, which increments the number of levels to
2578 check by the given value. [This is basically for use by internal
2579 functions like __begin_control which are always called by
2584 sub __internal_request{
2586 $l = 0 if not defined $l;
2587 if (defined +(caller(2+$l))[0] and +(caller(2+$l))[0] eq __PACKAGE__) {
2593 sub __return_append_to_log_options{
2595 my $action = $param{action} if exists $param{action};
2596 if (not exists $param{requester}) {
2597 $param{requester} = $config{control_internal_requester};
2599 if (not exists $param{request_addr}) {
2600 $param{request_addr} = $config{control_internal_request_addr};
2602 if (not exists $param{message}) {
2603 my $date = rfc822_date();
2604 $param{message} = fill_in_template(template => 'mail/fake_control_message',
2605 variables => {request_addr => $param{request_addr},
2606 requester => $param{requester},
2612 if (not defined $action) {
2613 carp "Undefined action!";
2614 $action = "unknown action";
2616 return (action => $action,
2617 (map {exists $append_action_options{$_}?($_,$param{$_}):()}
2622 =head2 __begin_control
2624 my %info = __begin_control(%param,
2626 command=>'unarchive');
2627 my ($debug,$transcript) = @info{qw(debug transcript)};
2628 my @data = @{$info{data}};
2629 my @bugs = @{$info{bugs}};
2632 Starts the process of modifying a bug; handles all of the generic
2633 things that almost every control request needs
2635 Returns a hash containing
2639 =item new_locks -- number of new locks taken out by this call
2641 =item debug -- the debug file handle
2643 =item transcript -- the transcript file handle
2645 =item data -- an arrayref containing the data of the bugs
2646 corresponding to this request
2648 =item bugs -- an arrayref containing the bug numbers of the bugs
2649 corresponding to this request
2657 sub __begin_control {
2658 my %param = validate_with(params => \@_,
2659 spec => {bug => {type => SCALAR,
2662 archived => {type => BOOLEAN,
2665 command => {type => SCALAR,
2673 my ($debug,$transcript) = __handle_debug_transcript(@_);
2674 print {$debug} "$param{bug} considering\n";
2676 my $old_die = $SIG{__DIE__};
2677 $SIG{__DIE__} = *sig_die{CODE};
2679 ($new_locks, @data) =
2680 lock_read_all_merged_bugs($param{bug},
2681 ($param{archived}?'archive':()));
2682 $locks += $new_locks;
2684 die "Unable to read any bugs successfully.";
2686 if (not __check_limit(data => \@data,
2687 exists $param{limit}?(limit => $param{limit}):(),
2689 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2692 __handle_affected_packages(%param,data => \@data);
2693 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2694 print {$debug} "$param{bug} read $locks locks\n";
2695 if (not @data or not defined $data[0]) {
2696 print {$transcript} "No bug found for $param{bug}\n";
2697 die "No bug found for $param{bug}";
2700 add_recipients(data => \@data,
2701 recipients => $param{recipients},
2702 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2704 transcript => $transcript,
2707 print {$debug} "$param{bug} read done\n";
2708 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2709 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2710 return (data => \@data,
2712 old_die => $old_die,
2713 new_locks => $new_locks,
2715 transcript => $transcript,
2720 =head2 __end_control
2722 __end_control(%info);
2724 Handles tearing down from a control request
2730 if (exists $info{new_locks} and $info{new_locks} > 0) {
2731 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2732 for (1..$info{new_locks}) {
2736 $SIG{__DIE__} = $info{old_die};
2737 if (exists $info{param}{bugs_affected}) {
2738 @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2740 add_recipients(recipients => $info{param}{recipients},
2741 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
2742 data => $info{data},
2743 debug => $info{debug},
2744 transcript => $info{transcript},
2746 __handle_affected_packages(%{$info{param}},data=>$info{data});
2750 =head2 __check_limit
2752 __check_limit(data => \@data, limit => $param{limit});
2755 Checks to make sure that bugs match any limits; each entry of @data
2756 much satisfy the limit.
2758 Returns true if there are no entries in data, or there are no keys in
2759 limit; returns false (0) if there are any entries which do not match.
2761 The limit hashref elements can contain an arrayref of scalars to
2762 match; regexes are also acccepted. At least one of the entries in each
2763 element needs to match the corresponding field in all data for the
2770 my %param = validate_with(params => \@_,
2771 spec => {data => {type => ARRAYREF|SCALAR,
2773 limit => {type => HASHREF|UNDEF,
2777 my @data = make_list($param{data});
2779 not defined $param{limit} or
2780 not keys %{$param{limit}}) {
2783 for my $data (@data) {
2784 for my $field (keys %{$param{limit}}) {
2785 next unless exists $param{limit}{$field};
2787 for my $limit (make_list($param{limit}{$field})) {
2788 if (not ref $limit) {
2789 if ($data->{$field} eq $limit) {
2794 elsif (ref($limit) eq 'Regexp') {
2795 if ($data->{$field} =~ $limit) {
2801 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
2817 We override die to specially handle unlocking files in the cases where
2818 we are called via eval. [If we're not called via eval, it doesn't
2824 #if ($^S) { # in eval
2826 for (1..$locks) { unfilelock(); }
2833 # =head2 __message_body_template
2835 # message_body_template('mail/ack',{ref=>'foo'});
2837 # Creates a message body using a template
2841 sub __message_body_template{
2842 my ($template,$extra_var) = @_;
2844 my $hole_var = {'&bugurl' =>
2846 'http://'.$config{cgi_domain}.'/'.
2847 Debbugs::CGI::bug_url($_[0]);
2851 my $body = fill_in_template(template => $template,
2852 variables => {config => \%config,
2855 hole_var => $hole_var,
2857 return fill_in_template(template => 'mail/message_body',
2858 variables => {config => \%config,
2862 hole_var => $hole_var,