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) '.english_join([keys %added_blockers]) if keys %added_blockers;
440 push @changed, 'removed blocking bug(s) '.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 %blocks = split ' ', $data->{blocks};
487 for my $bug (@bugs) {
488 if ($add_remove eq 'remove') {
489 next unless exists $blocks{$bug};
490 delete $blocks{$bug};
493 next if exists $blocks{$bug};
498 $data->{blocks} = join(' ',sort keys %blocks);
499 my $action = ($add_remove eq 'add'?'Added':'Removed').
500 " indication that bug $data->{bug_num} blocks".
502 append_action_to_log(bug => $data->{bug_num},
504 old_data => $old_data,
507 __return_append_to_log_options(%param,
512 __handle_affected_packages(%param,data=>\@blocking_data);
513 add_recipients(recipients => $param{recipients},
514 actions_taken => {blocks => 1},
515 data => \@blocking_data,
517 transcript => $transcript,
520 unfilelock() for $new_locks;
523 __end_control(%info);
532 transcript => $transcript,
533 ($dl > 0 ? (debug => $transcript):()),
534 requester => $header{from},
535 request_addr => $controlrequestaddr,
537 affected_packages => \%affected_packages,
538 recipients => \%recipients,
545 print {$transcript} "Failed to set tag on $ref: $@";
549 Sets, adds, or removes the specified tags on a bug
553 =item tag -- scalar or arrayref of tags to set, add or remove
555 =item add -- if true, add tags
557 =item remove -- if true, remove tags
559 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
567 my %param = validate_with(params => \@_,
568 spec => {bug => {type => SCALAR,
571 # specific options here
572 tag => {type => SCALAR|ARRAYREF,
575 add => {type => BOOLEAN,
578 remove => {type => BOOLEAN,
581 warn_on_bad_tags => {type => BOOLEAN,
585 %append_action_options,
588 if ($param{add} and $param{remove}) {
589 croak "It's nonsensical to add and remove the same tags";
593 __begin_control(%param,
596 my ($debug,$transcript) =
597 @info{qw(debug transcript)};
598 my @data = @{$info{data}};
599 my @bugs = @{$info{bugs}};
600 my @tags = make_list($param{tag});
601 if (not @tags and ($param{remove} or $param{add})) {
602 if ($param{remove}) {
603 print {$transcript} "Requested to remove no tags; doing nothing.\n";
606 print {$transcript} "Requested to add no tags; doing nothing.\n";
608 __end_control(%info);
611 # first things first, make the versions fully qualified source
613 for my $data (@data) {
614 my $action = 'Did not alter tags';
616 my %tag_removed = ();
617 my %fixed_removed = ();
618 my @old_tags = split /\,\s*/, $data->{keywords};
620 @tags{@old_tags} = (1) x @old_tags;
622 my $old_data = dclone($data);
623 if (not $param{add} and not $param{remove}) {
624 $tag_removed{$_} = 1 for @old_tags;
628 for my $tag (@tags) {
629 if (not $param{remove} and
630 not defined first {$_ eq $tag} @{$config{tags}}) {
631 push @bad_tags, $tag;
635 if (not exists $tags{$tag}) {
637 $tag_added{$tag} = 1;
640 elsif ($param{remove}) {
641 if (exists $tags{$tag}) {
643 $tag_removed{$tag} = 1;
647 if (exists $tag_removed{$tag}) {
648 delete $tag_removed{$tag};
651 $tag_added{$tag} = 1;
656 if (@bad_tags and $param{warn_on_bad_tags}) {
657 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
658 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
660 $data->{keywords} = join(', ',keys %tags); # double check this
663 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
664 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
665 $action = ucfirst(join ('; ',@changed)) if @changed;
667 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
668 unless __internal_request();
672 append_action_to_log(bug => $data->{bug_num},
675 old_data => $old_data,
677 __return_append_to_log_options(
682 if not exists $param{append_log} or $param{append_log};
683 writebug($data->{bug_num},$data);
684 print {$transcript} "$action\n";
686 __end_control(%info);
694 set_severity(bug => $ref,
695 transcript => $transcript,
696 ($dl > 0 ? (debug => $transcript):()),
697 requester => $header{from},
698 request_addr => $controlrequestaddr,
700 affected_packages => \%affected_packages,
701 recipients => \%recipients,
702 severity => 'normal',
707 print {$transcript} "Failed to set the severity of bug $ref: $@";
710 Sets the severity of a bug. If severity is not passed, is undefined,
711 or has zero length, sets the severity to the defafult severity.
716 my %param = validate_with(params => \@_,
717 spec => {bug => {type => SCALAR,
720 # specific options here
721 severity => {type => SCALAR|UNDEF,
722 default => $config{default_severity},
725 %append_action_options,
728 if (not defined $param{severity} or
729 not length $param{severity}
731 $param{severity} = $config{default_severity};
734 # check validity of new severity
735 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
736 die "Severity '$param{severity}' is not a valid severity level";
739 __begin_control(%param,
740 command => 'severity'
742 my ($debug,$transcript) =
743 @info{qw(debug transcript)};
744 my @data = @{$info{data}};
745 my @bugs = @{$info{bugs}};
748 for my $data (@data) {
749 if (not defined $data->{severity}) {
750 $data->{severity} = $param{severity};
751 $action = "Severity set to '$param{severity}'\n";
754 if ($data->{severity} eq '') {
755 $data->{severity} = $config{default_severity};
757 if ($data->{severity} eq $param{severity}) {
758 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
761 $action = "Severity set to '$param{severity}' from '$data->{severity}'\n";
762 $data->{severity} = $param{severity};
764 append_action_to_log(bug => $data->{bug_num},
766 __return_append_to_log_options(
771 if not exists $param{append_log} or $param{append_log};
772 writebug($data->{bug_num},$data);
773 print {$transcript} "$action\n";
775 __end_control(%info);
783 transcript => $transcript,
784 ($dl > 0 ? (debug => $transcript):()),
785 requester => $header{from},
786 request_addr => $controlrequestaddr,
788 affected_packages => \%affected_packages,
789 recipients => \%recipients,
795 print {$transcript} "Failed to set foo $ref bar: $@";
803 my %param = validate_with(params => \@_,
804 spec => {bug => {type => SCALAR,
807 # specific options here
808 submitter => {type => SCALAR|UNDEF,
812 %append_action_options,
816 $param{submitter} = undef if defined $param{submitter} and
817 not length $param{submitter};
819 if (defined $param{submitter} and
820 not Mail::RFC822::Address::valid($param{submitter})) {
821 die "New submitter address $param{submitter} is not a valid e-mail address";
825 __begin_control(%param,
828 my ($debug,$transcript) =
829 @info{qw(debug transcript)};
830 my @data = @{$info{data}};
831 my @bugs = @{$info{bugs}};
834 my $warn_fixed = 1; # avoid warning multiple times if there are
836 my @change_submitter = ();
837 my @bugs_to_reopen = ();
838 for my $data (@data) {
839 if (not exists $data->{done} or
840 not defined $data->{done} or
841 not length $data->{done}) {
842 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
843 __end_control(%info);
846 if (@{$data->{fixed_versions}} and $warn_fixed) {
847 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
848 print {$transcript} "you may need to use 'found' to remove fixed versions.\n";
851 if (defined $param{submitter} and length $param{submitter}
852 and $data->{originator} ne $param{submitter}) {
853 push @change_submitter,$data->{bug_num};
856 __end_control(%info);
857 my @params_for_subcalls =
858 map {exists $param{$_}?($_,$param{$_}):()}
859 (keys %common_options,
860 keys %append_action_options,
863 for my $bug (@change_submitter) {
864 set_submitter(bug=>$bug,
865 submitter => $param{submitter},
866 @params_for_subcalls,
869 set_fixed(fixed => [],
879 set_submitter(bug => $ref,
880 transcript => $transcript,
881 ($dl > 0 ? (debug => $transcript):()),
882 requester => $header{from},
883 request_addr => $controlrequestaddr,
885 affected_packages => \%affected_packages,
886 recipients => \%recipients,
887 submitter => $new_submitter,
888 notify_submitter => 1,
893 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
896 Sets the submitter of a bug. If notify_submitter is true (the
897 default), notifies the old submitter of a bug on changes
902 my %param = validate_with(params => \@_,
903 spec => {bug => {type => SCALAR,
906 # specific options here
907 submitter => {type => SCALAR,
909 notify_submitter => {type => BOOLEAN,
913 %append_action_options,
916 if (not Mail::RFC822::Address::valid($param{submitter})) {
917 die "New submitter address $param{submitter} is not a valid e-mail address";
920 __begin_control(%param,
921 command => 'submitter'
923 my ($debug,$transcript) =
924 @info{qw(debug transcript)};
925 my @data = @{$info{data}};
926 my @bugs = @{$info{bugs}};
928 # here we only concern ourselves with the first of the merged bugs
929 for my $data ($data[0]) {
930 my $notify_old_submitter = 0;
931 my $old_data = dclone($data);
932 print {$debug} "Going to change bug submitter\n";
933 if (((not defined $param{submitter} or not length $param{submitter}) and
934 (not defined $data->{originator} or not length $data->{originator})) or
935 (defined $param{submitter} and defined $data->{originator} and
936 $param{submitter} eq $data->{originator})) {
937 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
938 unless __internal_request();
942 if (defined $data->{originator} and length($data->{originator})) {
943 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
944 $notify_old_submitter = 1;
947 $action= "Set $config{bug} submitter to '$param{submitter}'.";
949 $data->{originator} = $param{submitter};
951 append_action_to_log(bug => $data->{bug_num},
952 command => 'submitter',
954 old_data => $old_data,
956 __return_append_to_log_options(
961 if not exists $param{append_log} or $param{append_log};
962 writebug($data->{bug_num},$data);
963 print {$transcript} "$action\n";
964 # notify old submitter
965 if ($notify_old_submitter and $param{notify_submitter}) {
966 send_mail_message(message =>
967 create_mime_message([default_headers(queue_file => $param{request_nn},
969 msgid => $param{request_msgid},
971 pr_msg => 'submitter-changed',
973 [To => $old_data->{submitter},
974 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
978 __message_body_template('mail/submitter_changed',
979 {old_data => $old_data,
981 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
985 recipients => $old_data->{submitter},
989 __end_control(%info);
997 set_forwarded(bug => $ref,
998 transcript => $transcript,
999 ($dl > 0 ? (debug => $transcript):()),
1000 requester => $header{from},
1001 request_addr => $controlrequestaddr,
1003 affected_packages => \%affected_packages,
1004 recipients => \%recipients,
1005 forwarded => $forward_to,
1010 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1013 Sets the location to which a bug is forwarded. Given an undef
1014 forwarded, unsets forwarded.
1020 my %param = validate_with(params => \@_,
1021 spec => {bug => {type => SCALAR,
1024 # specific options here
1025 forwarded => {type => SCALAR|UNDEF,
1028 %append_action_options,
1031 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1032 die "Non-printable characters are not allowed in the forwarded field";
1035 __begin_control(%param,
1036 command => 'forwarded'
1038 my ($debug,$transcript) =
1039 @info{qw(debug transcript)};
1040 my @data = @{$info{data}};
1041 my @bugs = @{$info{bugs}};
1043 for my $data (@data) {
1044 my $old_data = dclone($data);
1045 print {$debug} "Going to change bug forwarded\n";
1046 if (((not defined $param{forwarded} or not length $param{forwarded}) and
1047 (not defined $data->{forwarded} or not length $data->{forwarded})) or
1048 $param{forwarded} eq $data->{forwarded}) {
1049 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1050 unless __internal_request();
1054 if (not defined $param{forwarded}) {
1055 $action= "Unset $config{bug} forwarded-to-address";
1057 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1058 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1061 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1063 $data->{forwarded} = $param{forwarded};
1065 append_action_to_log(bug => $data->{bug_num},
1066 command => 'forwarded',
1068 old_data => $old_data,
1070 __return_append_to_log_options(
1075 if not exists $param{append_log} or $param{append_log};
1076 writebug($data->{bug_num},$data);
1077 print {$transcript} "$action\n";
1079 __end_control(%info);
1088 set_title(bug => $ref,
1089 transcript => $transcript,
1090 ($dl > 0 ? (debug => $transcript):()),
1091 requester => $header{from},
1092 request_addr => $controlrequestaddr,
1094 affected_packages => \%affected_packages,
1095 recipients => \%recipients,
1096 title => $new_title,
1101 print {$transcript} "Failed to set the title of $ref: $@";
1104 Sets the title of a specific bug
1110 my %param = validate_with(params => \@_,
1111 spec => {bug => {type => SCALAR,
1114 # specific options here
1115 title => {type => SCALAR,
1118 %append_action_options,
1121 if ($param{title} =~ /[^[:print:]]/) {
1122 die "Non-printable characters are not allowed in bug titles";
1125 my %info = __begin_control(%param,
1128 my ($debug,$transcript) =
1129 @info{qw(debug transcript)};
1130 my @data = @{$info{data}};
1131 my @bugs = @{$info{bugs}};
1133 for my $data (@data) {
1134 my $old_data = dclone($data);
1135 print {$debug} "Going to change bug title\n";
1136 if (defined $data->{subject} and length($data->{subject}) and
1137 $data->{subject} eq $param{title}) {
1138 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1139 unless __internal_request();
1143 if (defined $data->{subject} and length($data->{subject})) {
1144 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1146 $action= "Set $config{bug} title to '$param{title}'.";
1148 $data->{subject} = $param{title};
1150 append_action_to_log(bug => $data->{bug_num},
1153 old_data => $old_data,
1155 __return_append_to_log_options(
1160 if not exists $param{append_log} or $param{append_log};
1161 writebug($data->{bug_num},$data);
1162 print {$transcript} "$action\n";
1164 __end_control(%info);
1171 set_package(bug => $ref,
1172 transcript => $transcript,
1173 ($dl > 0 ? (debug => $transcript):()),
1174 requester => $header{from},
1175 request_addr => $controlrequestaddr,
1177 affected_packages => \%affected_packages,
1178 recipients => \%recipients,
1179 package => $new_package,
1185 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1188 Indicates that a bug is in a particular package. If is_source is true,
1189 indicates that the package is a source package. [Internally, this
1190 causes src: to be prepended to the package name.]
1192 The default for is_source is 0. As a special case, if the package
1193 starts with 'src:', it is assumed to be a source package and is_source
1196 The package option must match the package_name_re regex.
1201 my %param = validate_with(params => \@_,
1202 spec => {bug => {type => SCALAR,
1205 # specific options here
1206 package => {type => SCALAR|ARRAYREF,
1208 is_source => {type => BOOLEAN,
1212 %append_action_options,
1215 my @new_packages = map {splitpackages($_)} make_list($param{package});
1216 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1217 croak "Invalid package name '".
1218 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1221 my %info = __begin_control(%param,
1222 command => 'package',
1224 my ($debug,$transcript) =
1225 @info{qw(debug transcript)};
1226 my @data = @{$info{data}};
1227 my @bugs = @{$info{bugs}};
1228 # clean up the new package
1232 ($temp =~ s/^src:// or
1233 $param{is_source}) ? 'src:'.$temp:$temp;
1237 my $package_reassigned = 0;
1238 for my $data (@data) {
1239 my $old_data = dclone($data);
1240 print {$debug} "Going to change assigned package\n";
1241 if (defined $data->{package} and length($data->{package}) and
1242 $data->{package} eq $new_package) {
1243 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1244 unless __internal_request();
1248 if (defined $data->{package} and length($data->{package})) {
1249 $package_reassigned = 1;
1250 $action= "$config{bug} reassigned from package '$data->{package}'".
1251 " to '$new_package'.";
1253 $action= "$config{bug} assigned to package '$new_package'.";
1255 $data->{package} = $new_package;
1257 append_action_to_log(bug => $data->{bug_num},
1258 command => 'package',
1260 old_data => $old_data,
1262 __return_append_to_log_options(
1267 if not exists $param{append_log} or $param{append_log};
1268 writebug($data->{bug_num},$data);
1269 print {$transcript} "$action\n";
1271 __end_control(%info);
1272 # Only clear the fixed/found versions if the package has been
1274 if ($package_reassigned) {
1275 my @params_for_found_fixed =
1276 map {exists $param{$_}?($_,$param{$_}):()}
1278 keys %common_options,
1279 keys %append_action_options,
1281 set_found(found => [],
1282 @params_for_found_fixed,
1284 set_fixed(fixed => [],
1285 @params_for_found_fixed,
1293 set_found(bug => $ref,
1294 transcript => $transcript,
1295 ($dl > 0 ? (debug => $transcript):()),
1296 requester => $header{from},
1297 request_addr => $controlrequestaddr,
1299 affected_packages => \%affected_packages,
1300 recipients => \%recipients,
1307 print {$transcript} "Failed to set found on $ref: $@";
1311 Sets, adds, or removes the specified found versions of a package
1313 If the version list is empty, and the bug is currently not "done",
1314 causes the done field to be cleared.
1316 If any of the versions added to found are greater than any version in
1317 which the bug is fixed (or when the bug is found and there are no
1318 fixed versions) the done field is cleared.
1323 my %param = validate_with(params => \@_,
1324 spec => {bug => {type => SCALAR,
1327 # specific options here
1328 found => {type => SCALAR|ARRAYREF,
1331 add => {type => BOOLEAN,
1334 remove => {type => BOOLEAN,
1338 %append_action_options,
1341 if ($param{add} and $param{remove}) {
1342 croak "It's nonsensical to add and remove the same versions";
1346 __begin_control(%param,
1349 my ($debug,$transcript) =
1350 @info{qw(debug transcript)};
1351 my @data = @{$info{data}};
1352 my @bugs = @{$info{bugs}};
1354 for my $version (make_list($param{found})) {
1355 next unless defined $version;
1356 $versions{$version} =
1357 [make_source_versions(package => [splitpackages($data[0]{package})],
1358 warnings => $transcript,
1361 versions => $version,
1364 # This is really ugly, but it's what we have to do
1365 if (not @{$versions{$version}}) {
1366 print {$transcript} "Unable to make a source version for version '$version'\n";
1369 if (not keys %versions and ($param{remove} or $param{add})) {
1370 if ($param{remove}) {
1371 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1374 print {$transcript} "Requested to add no versions; doing nothing.\n";
1376 __end_control(%info);
1379 # first things first, make the versions fully qualified source
1381 for my $data (@data) {
1382 # The 'done' field gets a bit weird with version tracking,
1383 # because a bug may be closed by multiple people in different
1384 # branches. Until we have something more flexible, we set it
1385 # every time a bug is fixed, and clear it when a bug is found
1386 # in a version greater than any version in which the bug is
1387 # fixed or when a bug is found and there is no fixed version
1388 my $action = 'Did not alter found versions';
1389 my %found_added = ();
1390 my %found_removed = ();
1391 my %fixed_removed = ();
1393 my $old_data = dclone($data);
1394 if (not $param{add} and not $param{remove}) {
1395 $found_removed{$_} = 1 for @{$data->{found_versions}};
1396 $data->{found_versions} = [];
1399 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1401 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1402 for my $version (keys %versions) {
1404 my @svers = @{$versions{$version}};
1408 for my $sver (@svers) {
1409 if (not exists $found_versions{$sver}) {
1410 $found_versions{$sver} = 1;
1411 $found_added{$sver} = 1;
1413 # if the found we are adding matches any fixed
1414 # versions, remove them
1415 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1416 delete $fixed_versions{$_} for @temp;
1417 $fixed_removed{$_} = 1 for @temp;
1420 # We only care about reopening the bug if the bug is
1422 if (defined $data->{done} and length $data->{done}) {
1423 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1424 map {m{([^/]+)$}; $1;} @svers;
1425 # determine if we need to reopen
1426 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1427 map {m{([^/]+)$}; $1;} keys %fixed_versions;
1428 if (not @fixed_order or
1429 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1435 elsif ($param{remove}) {
1436 # in the case of removal, we only concern ourself with
1437 # the version passed, not the source version it maps
1439 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1440 delete $found_versions{$_} for @temp;
1441 $found_removed{$_} = 1 for @temp;
1444 # set the keys to exactly these values
1445 my @svers = @{$versions{$version}};
1449 for my $sver (@svers) {
1450 if (not exists $found_versions{$sver}) {
1451 $found_versions{$sver} = 1;
1452 if (exists $found_removed{$sver}) {
1453 delete $found_removed{$sver};
1456 $found_added{$sver} = 1;
1463 $data->{found_versions} = [keys %found_versions];
1464 $data->{fixed_versions} = [keys %fixed_versions];
1467 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1468 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1469 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1470 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1471 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1473 $action .= " and reopened"
1475 if (not $reopened and not @changed) {
1476 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1477 unless __internal_request();
1481 append_action_to_log(bug => $data->{bug_num},
1484 old_data => $old_data,
1486 __return_append_to_log_options(
1491 if not exists $param{append_log} or $param{append_log};
1492 writebug($data->{bug_num},$data);
1493 print {$transcript} "$action\n";
1495 __end_control(%info);
1501 set_fixed(bug => $ref,
1502 transcript => $transcript,
1503 ($dl > 0 ? (debug => $transcript):()),
1504 requester => $header{from},
1505 request_addr => $controlrequestaddr,
1507 affected_packages => \%affected_packages,
1508 recipients => \%recipients,
1516 print {$transcript} "Failed to set fixed on $ref: $@";
1520 Sets, adds, or removes the specified fixed versions of a package
1522 If the fixed versions are empty (or end up being empty after this
1523 call) or the greatest fixed version is less than the greatest found
1524 version and the reopen option is true, the bug is reopened.
1526 This function is also called by the reopen function, which causes all
1527 of the fixed versions to be cleared.
1532 my %param = validate_with(params => \@_,
1533 spec => {bug => {type => SCALAR,
1536 # specific options here
1537 fixed => {type => SCALAR|ARRAYREF,
1540 add => {type => BOOLEAN,
1543 remove => {type => BOOLEAN,
1546 reopen => {type => BOOLEAN,
1550 %append_action_options,
1553 if ($param{add} and $param{remove}) {
1554 croak "It's nonsensical to add and remove the same versions";
1557 __begin_control(%param,
1560 my ($debug,$transcript) =
1561 @info{qw(debug transcript)};
1562 my @data = @{$info{data}};
1563 my @bugs = @{$info{bugs}};
1565 for my $version (make_list($param{fixed})) {
1566 next unless defined $version;
1567 $versions{$version} =
1568 [make_source_versions(package => [splitpackages($data[0]{package})],
1569 warnings => $transcript,
1572 versions => $version,
1575 # This is really ugly, but it's what we have to do
1576 if (not @{$versions{$version}}) {
1577 print {$transcript} "Unable to make a source version for version '$version'\n";
1580 if (not keys %versions and ($param{remove} or $param{add})) {
1581 if ($param{remove}) {
1582 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1585 print {$transcript} "Requested to add no versions; doing nothing.\n";
1587 __end_control(%info);
1590 # first things first, make the versions fully qualified source
1592 for my $data (@data) {
1593 my $old_data = dclone($data);
1594 # The 'done' field gets a bit weird with version tracking,
1595 # because a bug may be closed by multiple people in different
1596 # branches. Until we have something more flexible, we set it
1597 # every time a bug is fixed, and clear it when a bug is found
1598 # in a version greater than any version in which the bug is
1599 # fixed or when a bug is found and there is no fixed version
1600 my $action = 'Did not alter fixed versions';
1601 my %found_added = ();
1602 my %found_removed = ();
1603 my %fixed_added = ();
1604 my %fixed_removed = ();
1606 if (not $param{add} and not $param{remove}) {
1607 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1608 $data->{fixed_versions} = [];
1611 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1613 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1614 for my $version (keys %versions) {
1616 my @svers = @{$versions{$version}};
1620 for my $sver (@svers) {
1621 if (not exists $fixed_versions{$sver}) {
1622 $fixed_versions{$sver} = 1;
1623 $fixed_added{$sver} = 1;
1627 elsif ($param{remove}) {
1628 # in the case of removal, we only concern ourself with
1629 # the version passed, not the source version it maps
1631 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1632 delete $fixed_versions{$_} for @temp;
1633 $fixed_removed{$_} = 1 for @temp;
1636 # set the keys to exactly these values
1637 my @svers = @{$versions{$version}};
1641 for my $sver (@svers) {
1642 if (not exists $fixed_versions{$sver}) {
1643 $fixed_versions{$sver} = 1;
1644 if (exists $fixed_removed{$sver}) {
1645 delete $fixed_removed{$sver};
1648 $fixed_added{$sver} = 1;
1655 $data->{found_versions} = [keys %found_versions];
1656 $data->{fixed_versions} = [keys %fixed_versions];
1658 # If we're supposed to consider reopening, reopen if the
1659 # fixed versions are empty or the greatest found version
1660 # is greater than the greatest fixed version
1661 if ($param{reopen} and defined $data->{done}
1662 and length $data->{done}) {
1663 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1664 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1665 # determine if we need to reopen
1666 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1667 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1668 if (not @fixed_order or
1669 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1676 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1677 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1678 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1679 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1680 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1682 $action .= " and reopened"
1684 if (not $reopened and not @changed) {
1685 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1686 unless __internal_request();
1690 append_action_to_log(bug => $data->{bug_num},
1693 old_data => $old_data,
1695 __return_append_to_log_options(
1700 if not exists $param{append_log} or $param{append_log};
1701 writebug($data->{bug_num},$data);
1702 print {$transcript} "$action\n";
1704 __end_control(%info);
1712 affects(bug => $ref,
1713 transcript => $transcript,
1714 ($dl > 0 ? (debug => $transcript):()),
1715 requester => $header{from},
1716 request_addr => $controlrequestaddr,
1718 affected_packages => \%affected_packages,
1719 recipients => \%recipients,
1727 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
1730 This marks a bug as affecting packages which the bug is not actually
1731 in. This should only be used in cases where fixing the bug instantly
1732 resolves the problem in the other packages.
1734 By default, the packages are set to the list of packages passed.
1735 However, if you pass add => 1 or remove => 1, the list of packages
1736 passed are added or removed from the affects list, respectively.
1741 my %param = validate_with(params => \@_,
1742 spec => {bug => {type => SCALAR,
1745 # specific options here
1746 packages => {type => SCALAR|ARRAYREF,
1749 add => {type => BOOLEAN,
1752 remove => {type => BOOLEAN,
1756 %append_action_options,
1759 if ($param{add} and $param{remove}) {
1760 croak "Asking to both add and remove affects is nonsensical";
1763 __begin_control(%param,
1764 command => 'affects'
1766 my ($debug,$transcript) =
1767 @info{qw(debug transcript)};
1768 my @data = @{$info{data}};
1769 my @bugs = @{$info{bugs}};
1771 for my $data (@data) {
1773 print {$debug} "Going to change affects\n";
1774 my @packages = splitpackages($data->{affects});
1776 @packages{@packages} = (1) x @packages;
1779 for my $package (make_list($param{packages})) {
1780 next unless defined $package and length $package;
1781 if (not $packages{$package}) {
1782 $packages{$package} = 1;
1783 push @added,$package;
1787 $action = "Added indication that $data->{bug_num} affects ".
1788 english_join(\@added);
1791 elsif ($param{remove}) {
1793 for my $package (make_list($param{packages})) {
1794 if ($packages{$package}) {
1795 next unless defined $package and length $package;
1796 delete $packages{$package};
1797 push @removed,$package;
1800 $action = "Removed indication that $data->{bug_num} affects " .
1801 english_join(\@removed);
1804 my %added_packages = ();
1805 my %removed_packages = %packages;
1807 for my $package (make_list($param{packages})) {
1808 next unless defined $package and length $package;
1809 $packages{$package} = 1;
1810 delete $removed_packages{$package};
1811 $added_packages{$package} = 1;
1813 if (keys %removed_packages) {
1814 $action = "Removed indication that $data->{bug_num} affects ".
1815 english_join([keys %removed_packages]);
1816 $action .= "\n" if keys %added_packages;
1818 if (keys %added_packages) {
1819 $action .= "Added indication that $data->{bug_num} affects " .
1820 english_join([%added_packages]);
1823 if (not length $action) {
1824 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
1825 unless __internal_request();
1827 my $old_data = dclone($data);
1828 $data->{affects} = join(',',keys %packages);
1829 append_action_to_log(bug => $data->{bug_num},
1831 command => 'affects',
1833 old_data => $old_data,
1834 __return_append_to_log_options(
1839 if not exists $param{append_log} or $param{append_log};
1840 writebug($data->{bug_num},$data);
1841 print {$transcript} "$action\n";
1843 __end_control(%info);
1847 =head1 SUMMARY FUNCTIONS
1852 summary(bug => $ref,
1853 transcript => $transcript,
1854 ($dl > 0 ? (debug => $transcript):()),
1855 requester => $header{from},
1856 request_addr => $controlrequestaddr,
1858 affected_packages => \%affected_packages,
1859 recipients => \%recipients,
1865 print {$transcript} "Failed to mark $ref with summary foo: $@";
1868 Handles all setting of summary fields
1870 If summary is undef, unsets the summary
1872 If summary is 0, sets the summary to the first paragraph contained in
1875 If summary is numeric, sets the summary to the message specified.
1882 my %param = validate_with(params => \@_,
1883 spec => {bug => {type => SCALAR,
1886 # specific options here
1887 summary => {type => SCALAR|UNDEF,
1891 %append_action_options,
1894 croak "summary must be numeric or undef" if
1895 defined $param{summary} and not $param{summary} =~ /^\d+$/;
1897 __begin_control(%param,
1898 command => 'summary'
1900 my ($debug,$transcript) =
1901 @info{qw(debug transcript)};
1902 my @data = @{$info{data}};
1903 my @bugs = @{$info{bugs}};
1904 # figure out the log that we're going to use
1906 my $summary_msg = '';
1908 if (not defined $param{summary}) {
1910 print {$debug} "Removing summary fields\n";
1911 $action = 'Removed summary';
1915 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
1916 if ($param{summary} == 0) {
1917 $log = $param{message};
1918 $summary_msg = @records + 1;
1921 if (($param{summary} - 1 ) > $#records) {
1922 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
1924 my $record = $records[($param{summary} - 1 )];
1925 if ($record->{type} !~ /incoming-recv|recips/) {
1926 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
1928 $summary_msg = $param{summary};
1929 $log = [$record->{text}];
1931 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
1932 my $body = $p_o->{body};
1933 my $in_pseudoheaders = 0;
1935 # walk through body until we get non-blank lines
1936 for my $line (@{$body}) {
1937 if ($line =~ /^\s*$/) {
1938 if (length $paragraph) {
1939 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
1945 $in_pseudoheaders = 0;
1948 # skip a paragraph if it looks like it's control or
1950 if ($line =~ m{^\s*(?:(?:Package|Source|Version)\:| #pseudo headers
1951 (?:package|(?:no|)owner|severity|tag|summary| #control
1952 reopen|close|(?:not|)(?:fixed|found)|clone|
1953 (?:force|)merge|user(?:category|tag|)
1956 if (not length $paragraph) {
1957 print {$debug} "Found control/pseudo-headers and skiping them\n";
1958 $in_pseudoheaders = 1;
1962 next if $in_pseudoheaders;
1963 $paragraph .= $line ." \n";
1965 print {$debug} "Summary is going to be '$paragraph'\n";
1966 $summary = $paragraph;
1967 $summary =~ s/[\n\r]/ /g;
1968 if (not length $summary) {
1969 die "Unable to find summary message to use";
1971 # trim off a trailing spaces
1972 $summary =~ s/\ *$//;
1974 for my $data (@data) {
1975 print {$debug} "Going to change summary\n";
1976 if (((not defined $summary or not length $summary) and
1977 (not defined $data->{summary} or not length $data->{summary})) or
1978 $summary eq $data->{summary}) {
1979 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1980 unless __internal_request();
1983 if (length $summary) {
1984 if (length $data->{summary}) {
1985 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1988 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1991 my $old_data = dclone($data);
1992 $data->{summary} = $summary;
1993 append_action_to_log(bug => $data->{bug_num},
1994 command => 'summary',
1995 old_data => $old_data,
1998 __return_append_to_log_options(
2003 if not exists $param{append_log} or $param{append_log};
2004 writebug($data->{bug_num},$data);
2005 print {$transcript} "$action\n";
2007 __end_control(%info);
2013 =head1 OWNER FUNCTIONS
2019 transcript => $transcript,
2020 ($dl > 0 ? (debug => $transcript):()),
2021 requester => $header{from},
2022 request_addr => $controlrequestaddr,
2024 recipients => \%recipients,
2030 print {$transcript} "Failed to mark $ref as having an owner: $@";
2033 Handles all setting of the owner field; given an owner of undef or of
2034 no length, indicates that a bug is not owned by anyone.
2039 my %param = validate_with(params => \@_,
2040 spec => {bug => {type => SCALAR,
2043 owner => {type => SCALAR|UNDEF,
2046 %append_action_options,
2050 __begin_control(%param,
2053 my ($debug,$transcript) =
2054 @info{qw(debug transcript)};
2055 my @data = @{$info{data}};
2056 my @bugs = @{$info{bugs}};
2058 for my $data (@data) {
2059 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2060 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2061 if (not defined $param{owner} or not length $param{owner}) {
2062 if (not defined $data->{owner} or not length $data->{owner}) {
2063 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2064 unless __internal_request();
2068 $action = "Removed annotation that $config{bug} was owned by " .
2072 if ($data->{owner} eq $param{owner}) {
2073 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2076 if (length $data->{owner}) {
2077 $action = "Owner changed from $data->{owner} to $param{owner}.";
2080 $action = "Owner recorded as $param{owner}."
2083 my $old_data = dclone($data);
2084 $data->{owner} = $param{owner};
2085 append_action_to_log(bug => $data->{bug_num},
2088 old_data => $old_data,
2090 __return_append_to_log_options(
2095 if not exists $param{append_log} or $param{append_log};
2096 writebug($data->{bug_num},$data);
2097 print {$transcript} "$action\n";
2099 __end_control(%info);
2103 =head1 ARCHIVE FUNCTIONS
2110 bug_archive(bug => $bug_num,
2112 transcript => \$transcript,
2117 transcript("Unable to archive $bug_num\n");
2120 transcript($transcript);
2123 This routine archives a bug
2127 =item bug -- bug number
2129 =item check_archiveable -- check wether a bug is archiveable before
2130 archiving; defaults to 1
2132 =item archive_unarchived -- whether to archive bugs which have not
2133 previously been archived; defaults to 1. [Set to 0 when used from
2136 =item ignore_time -- whether to ignore time constraints when archiving
2137 a bug; defaults to 0.
2144 my %param = validate_with(params => \@_,
2145 spec => {bug => {type => SCALAR,
2148 check_archiveable => {type => BOOLEAN,
2151 archive_unarchived => {type => BOOLEAN,
2154 ignore_time => {type => BOOLEAN,
2158 %append_action_options,
2161 my %info = __begin_control(%param,
2162 command => 'archive',
2164 my ($debug,$transcript) = @info{qw(debug transcript)};
2165 my @data = @{$info{data}};
2166 my @bugs = @{$info{bugs}};
2167 my $action = "$config{bug} archived.";
2168 if ($param{check_archiveable} and
2169 not bug_archiveable(bug=>$param{bug},
2170 ignore_time => $param{ignore_time},
2172 print {$transcript} "Bug $param{bug} cannot be archived\n";
2173 die "Bug $param{bug} cannot be archived";
2175 print {$debug} "$param{bug} considering\n";
2176 if (not $param{archive_unarchived} and
2177 not exists $data[0]{unarchived}
2179 print {$transcript} "$param{bug} has not been archived previously\n";
2180 die "$param{bug} has not been archived previously";
2182 add_recipients(recipients => $param{recipients},
2185 transcript => $transcript,
2187 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2188 for my $bug (@bugs) {
2189 if ($param{check_archiveable}) {
2190 die "Bug $bug cannot be archived (but $param{bug} can?)"
2191 unless bug_archiveable(bug=>$bug,
2192 ignore_time => $param{ignore_time},
2196 # If we get here, we can archive/remove this bug
2197 print {$debug} "$param{bug} removing\n";
2198 for my $bug (@bugs) {
2199 #print "$param{bug} removing $bug\n" if $debug;
2200 my $dir = get_hashname($bug);
2201 # First indicate that this bug is being archived
2202 append_action_to_log(bug => $bug,
2204 command => 'archive',
2205 # we didn't actually change the data
2206 # when we archived, so we don't pass
2207 # a real new_data or old_data
2210 __return_append_to_log_options(
2215 if not exists $param{append_log} or $param{append_log};
2216 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2217 if ($config{save_old_bugs}) {
2218 mkpath("$config{spool_dir}/archive/$dir");
2219 foreach my $file (@files_to_remove) {
2220 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2221 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2222 # we need to bail out here if things have
2223 # gone horribly wrong to avoid removing a
2225 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2228 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2230 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2231 print {$transcript} "deleted $bug (from $param{bug})\n";
2233 bughook_archive(@bugs);
2234 __end_control(%info);
2237 =head2 bug_unarchive
2241 bug_unarchive(bug => $bug_num,
2243 transcript => \$transcript,
2248 transcript("Unable to archive bug: $bug_num");
2250 transcript($transcript);
2252 This routine unarchives a bug
2257 my %param = validate_with(params => \@_,
2258 spec => {bug => {type => SCALAR,
2262 %append_action_options,
2266 my %info = __begin_control(%param,
2268 command=>'unarchive');
2269 my ($debug,$transcript) =
2270 @info{qw(debug transcript)};
2271 my @data = @{$info{data}};
2272 my @bugs = @{$info{bugs}};
2273 my $action = "$config{bug} unarchived.";
2274 my @files_to_remove;
2275 for my $bug (@bugs) {
2276 print {$debug} "$param{bug} removing $bug\n";
2277 my $dir = get_hashname($bug);
2278 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
2279 mkpath("archive/$dir");
2280 foreach my $file (@files_to_copy) {
2281 # die'ing here sucks
2282 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2283 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2284 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
2286 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
2287 print {$transcript} "Unarchived $config{bug} $bug\n";
2289 unlink(@files_to_remove) or die "Unable to unlink bugs";
2290 # Indicate that this bug has been archived previously
2291 for my $bug (@bugs) {
2292 my $newdata = readbug($bug);
2293 my $old_data = dclone($newdata);
2294 if (not defined $newdata) {
2295 print {$transcript} "$config{bug} $bug disappeared!\n";
2296 die "Bug $bug disappeared!";
2298 $newdata->{unarchived} = time;
2299 append_action_to_log(bug => $bug,
2301 command => 'unarchive',
2302 new_data => $newdata,
2303 old_data => $old_data,
2304 __return_append_to_log_options(
2309 if not exists $param{append_log} or $param{append_log};
2310 writebug($bug,$newdata);
2312 __end_control(%info);
2315 =head2 append_action_to_log
2317 append_action_to_log
2319 This should probably be moved to Debbugs::Log; have to think that out
2324 sub append_action_to_log{
2325 my %param = validate_with(params => \@_,
2326 spec => {bug => {type => SCALAR,
2329 new_data => {type => HASHREF,
2332 old_data => {type => HASHREF,
2335 command => {type => SCALAR,
2338 action => {type => SCALAR,
2340 requester => {type => SCALAR,
2343 request_addr => {type => SCALAR,
2346 location => {type => SCALAR,
2349 message => {type => SCALAR|ARRAYREF,
2352 desc => {type => SCALAR,
2355 get_lock => {type => BOOLEAN,
2359 # append_action_options here
2360 # because some of these
2361 # options aren't actually
2362 # optional, even though the
2363 # original function doesn't
2367 # Fix this to use $param{location}
2368 my $log_location = buglog($param{bug});
2369 die "Unable to find .log for $param{bug}"
2370 if not defined $log_location;
2371 if ($param{get_lock}) {
2372 filelock("lock/$param{bug}");
2374 my $log = IO::File->new(">>$log_location") or
2375 die "Unable to open $log_location for appending: $!";
2376 # determine difference between old and new
2378 if (exists $param{old_data} and exists $param{new_data}) {
2379 my $old_data = dclone($param{old_data});
2380 my $new_data = dclone($param{new_data});
2381 for my $key (keys %{$old_data}) {
2382 if (not exists $Debbugs::Status::fields{$key}) {
2383 delete $old_data->{$key};
2386 next unless exists $new_data->{$key};
2387 next unless defined $new_data->{$key};
2388 if (not defined $old_data->{$key}) {
2389 delete $old_data->{$key};
2392 if (ref($new_data->{$key}) and
2393 ref($old_data->{$key}) and
2394 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2395 local $Storable::canonical = 1;
2396 # print STDERR Dumper($new_data,$old_data,$key);
2397 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2398 delete $new_data->{$key};
2399 delete $old_data->{$key};
2402 elsif ($new_data->{$key} eq $old_data->{$key}) {
2403 delete $new_data->{$key};
2404 delete $old_data->{$key};
2407 for my $key (keys %{$new_data}) {
2408 if (not exists $Debbugs::Status::fields{$key}) {
2409 delete $new_data->{$key};
2412 next unless exists $old_data->{$key};
2413 next unless defined $old_data->{$key};
2414 if (not defined $new_data->{$key} or
2415 not exists $Debbugs::Status::fields{$key}) {
2416 delete $new_data->{$key};
2419 if (ref($new_data->{$key}) and
2420 ref($old_data->{$key}) and
2421 ref($new_data->{$key}) eq ref($old_data->{$key})) {
2422 local $Storable::canonical = 1;
2423 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2424 delete $new_data->{$key};
2425 delete $old_data->{$key};
2428 elsif ($new_data->{$key} eq $old_data->{$key}) {
2429 delete $new_data->{$key};
2430 delete $old_data->{$key};
2433 $data_diff .= "<!-- new_data:\n";
2435 for my $key (keys %{$new_data}) {
2436 if (not exists $Debbugs::Status::fields{$key}) {
2437 warn "No such field $key";
2440 $nd{$key} = $new_data->{$key};
2441 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
2443 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
2444 $data_diff .= "-->\n";
2445 $data_diff .= "<!-- old_data:\n";
2447 for my $key (keys %{$old_data}) {
2448 if (not exists $Debbugs::Status::fields{$key}) {
2449 warn "No such field $key";
2452 $od{$key} = $old_data->{$key};
2453 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
2455 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
2456 $data_diff .= "-->\n";
2458 my $msg = join('',"\6\n",
2459 (exists $param{command} ?
2460 "<!-- command:".html_escape($param{command})." -->\n":""
2462 (length $param{requester} ?
2463 "<!-- requester: ".html_escape($param{requester})." -->\n":""
2465 (length $param{request_addr} ?
2466 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
2468 "<!-- time:".time()." -->\n",
2470 "<strong>".html_escape($param{action})."</strong>\n");
2471 if (length $param{requester}) {
2472 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
2474 if (length $param{request_addr}) {
2475 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
2477 if (length $param{desc}) {
2478 $msg .= ":<br>\n$param{desc}\n";
2484 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
2485 $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
2486 or die "Unable to append to $log_location: $!";
2488 print {$log} $msg or die "Unable to append to $log_location: $!";
2489 close $log or die "Unable to close $log_location: $!";
2490 if ($param{get_lock}) {
2498 =head1 PRIVATE FUNCTIONS
2500 =head2 __handle_affected_packages
2502 __handle_affected_packages(affected_packages => {},
2510 sub __handle_affected_packages{
2511 my %param = validate_with(params => \@_,
2512 spec => {%common_options,
2513 data => {type => ARRAYREF|HASHREF
2518 for my $data (make_list($param{data})) {
2519 next unless exists $data->{package} and defined $data->{package};
2520 my @packages = split /\s*,\s*/,$data->{package};
2521 @{$param{affected_packages}}{@packages} = (1) x @packages;
2525 =head2 __handle_debug_transcript
2527 my ($debug,$transcript) = __handle_debug_transcript(%param);
2529 Returns a debug and transcript filehandle
2534 sub __handle_debug_transcript{
2535 my %param = validate_with(params => \@_,
2536 spec => {%common_options},
2539 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
2540 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
2541 return ($debug,$transcript);
2548 Produces a small bit of bug information to kick out to the transcript
2555 next unless defined $data and exists $data->{bug_num};
2556 $return .= "Bug #".($data->{bug_num}||'').
2557 ((defined $data->{done} and length $data->{done})?
2558 " {Done: $data->{done}}":''
2560 " [".($data->{package}||'(no package)'). "] ".
2561 ($data->{subject}||'(no subject)')."\n";
2567 =head2 __internal_request
2569 __internal_request()
2570 __internal_request($level)
2572 Returns true if the caller of the function calling __internal_request
2573 belongs to __PACKAGE__
2575 This allows us to be magical, and don't bother to print bug info if
2576 the second caller is from this package, amongst other things.
2578 An optional level is allowed, which increments the number of levels to
2579 check by the given value. [This is basically for use by internal
2580 functions like __begin_control which are always called by
2585 sub __internal_request{
2587 $l = 0 if not defined $l;
2588 if (defined +(caller(2+$l))[0] and +(caller(2+$l))[0] eq __PACKAGE__) {
2594 sub __return_append_to_log_options{
2596 my $action = $param{action} if exists $param{action};
2597 if (not exists $param{requester}) {
2598 $param{requester} = $config{control_internal_requester};
2600 if (not exists $param{request_addr}) {
2601 $param{request_addr} = $config{control_internal_request_addr};
2603 if (not exists $param{message}) {
2604 my $date = rfc822_date();
2605 $param{message} = fill_in_template(template => 'mail/fake_control_message',
2606 variables => {request_addr => $param{request_addr},
2607 requester => $param{requester},
2613 if (not defined $action) {
2614 carp "Undefined action!";
2615 $action = "unknown action";
2617 return (action => $action,
2618 (map {exists $append_action_options{$_}?($_,$param{$_}):()}
2623 =head2 __begin_control
2625 my %info = __begin_control(%param,
2627 command=>'unarchive');
2628 my ($debug,$transcript) = @info{qw(debug transcript)};
2629 my @data = @{$info{data}};
2630 my @bugs = @{$info{bugs}};
2633 Starts the process of modifying a bug; handles all of the generic
2634 things that almost every control request needs
2636 Returns a hash containing
2640 =item new_locks -- number of new locks taken out by this call
2642 =item debug -- the debug file handle
2644 =item transcript -- the transcript file handle
2646 =item data -- an arrayref containing the data of the bugs
2647 corresponding to this request
2649 =item bugs -- an arrayref containing the bug numbers of the bugs
2650 corresponding to this request
2658 sub __begin_control {
2659 my %param = validate_with(params => \@_,
2660 spec => {bug => {type => SCALAR,
2663 archived => {type => BOOLEAN,
2666 command => {type => SCALAR,
2674 my ($debug,$transcript) = __handle_debug_transcript(@_);
2675 print {$debug} "$param{bug} considering\n";
2677 my $old_die = $SIG{__DIE__};
2678 $SIG{__DIE__} = *sig_die{CODE};
2680 ($new_locks, @data) =
2681 lock_read_all_merged_bugs($param{bug},
2682 ($param{archived}?'archive':()));
2683 $locks += $new_locks;
2685 die "Unable to read any bugs successfully.";
2687 if (not __check_limit(data => \@data,
2688 exists $param{limit}?(limit => $param{limit}):(),
2690 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2693 __handle_affected_packages(%param,data => \@data);
2694 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2695 print {$debug} "$param{bug} read $locks locks\n";
2696 if (not @data or not defined $data[0]) {
2697 print {$transcript} "No bug found for $param{bug}\n";
2698 die "No bug found for $param{bug}";
2701 add_recipients(data => \@data,
2702 recipients => $param{recipients},
2703 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2705 transcript => $transcript,
2708 print {$debug} "$param{bug} read done\n";
2709 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2710 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2711 return (data => \@data,
2713 old_die => $old_die,
2714 new_locks => $new_locks,
2716 transcript => $transcript,
2721 =head2 __end_control
2723 __end_control(%info);
2725 Handles tearing down from a control request
2731 if (exists $info{new_locks} and $info{new_locks} > 0) {
2732 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2733 for (1..$info{new_locks}) {
2737 $SIG{__DIE__} = $info{old_die};
2738 if (exists $info{param}{bugs_affected}) {
2739 @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2741 add_recipients(recipients => $info{param}{recipients},
2742 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
2743 data => $info{data},
2744 debug => $info{debug},
2745 transcript => $info{transcript},
2747 __handle_affected_packages(%{$info{param}},data=>$info{data});
2751 =head2 __check_limit
2753 __check_limit(data => \@data, limit => $param{limit});
2756 Checks to make sure that bugs match any limits; each entry of @data
2757 much satisfy the limit.
2759 Returns true if there are no entries in data, or there are no keys in
2760 limit; returns false (0) if there are any entries which do not match.
2762 The limit hashref elements can contain an arrayref of scalars to
2763 match; regexes are also acccepted. At least one of the entries in each
2764 element needs to match the corresponding field in all data for the
2771 my %param = validate_with(params => \@_,
2772 spec => {data => {type => ARRAYREF|SCALAR,
2774 limit => {type => HASHREF|UNDEF,
2778 my @data = make_list($param{data});
2780 not defined $param{limit} or
2781 not keys %{$param{limit}}) {
2784 for my $data (@data) {
2785 for my $field (keys %{$param{limit}}) {
2786 next unless exists $param{limit}{$field};
2788 for my $limit (make_list($param{limit}{$field})) {
2789 if (not ref $limit) {
2790 if ($data->{$field} eq $limit) {
2795 elsif (ref($limit) eq 'Regexp') {
2796 if ($data->{$field} =~ $limit) {
2802 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
2818 We override die to specially handle unlocking files in the cases where
2819 we are called via eval. [If we're not called via eval, it doesn't
2825 #if ($^S) { # in eval
2827 for (1..$locks) { unfilelock(); }
2834 # =head2 __message_body_template
2836 # message_body_template('mail/ack',{ref=>'foo'});
2838 # Creates a message body using a template
2842 sub __message_body_template{
2843 my ($template,$extra_var) = @_;
2845 my $hole_var = {'&bugurl' =>
2847 'http://'.$config{cgi_domain}.'/'.
2848 Debbugs::CGI::bug_url($_[0]);
2852 my $body = fill_in_template(template => $template,
2853 variables => {config => \%config,
2856 hole_var => $hole_var,
2858 return fill_in_template(template => 'mail/message_body',
2859 variables => {config => \%config,
2863 hole_var => $hole_var,