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 Exporter qw(import);
82 $DEBUG = 0 unless defined $DEBUG;
85 %EXPORT_TAGS = (done => [qw(set_done)],
86 submitter => [qw(set_submitter)],
87 severity => [qw(set_severity)],
88 affects => [qw(affects)],
89 summary => [qw(summary)],
90 outlook => [qw(outlook)],
92 title => [qw(set_title)],
93 forward => [qw(set_forwarded)],
94 found => [qw(set_found set_fixed)],
95 fixed => [qw(set_found set_fixed)],
96 package => [qw(set_package)],
97 block => [qw(set_blocks)],
98 merge => [qw(set_merged)],
100 clone => [qw(clone_bug)],
101 archive => [qw(bug_archive bug_unarchive),
103 limit => [qw(check_limit)],
104 log => [qw(append_action_to_log),
108 Exporter::export_ok_tags(keys %EXPORT_TAGS);
109 $EXPORT_TAGS{all} = [@EXPORT_OK];
112 use Debbugs::Config qw(:config);
113 use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions);
115 use Debbugs::Status qw(bug_archiveable :read :hook writebug new_bug splitpackages split_status_fields get_bug_status);
116 use Debbugs::CGI qw(html_escape);
117 use Debbugs::Log qw(:misc :write);
118 use Debbugs::Recipients qw(:add);
119 use Debbugs::Packages qw(:versions :mapping);
121 use Data::Dumper qw();
122 use Params::Validate qw(validate_with :types);
123 use File::Path qw(mkpath);
124 use File::Copy qw(copy);
127 use Debbugs::Text qw(:templates);
129 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers encode_headers);
130 use Debbugs::MIME qw(create_mime_message);
132 use Mail::RFC822::Address qw();
134 use POSIX qw(strftime);
136 use Storable qw(dclone nfreeze);
137 use List::Util qw(first max);
138 use Encode qw(encode_utf8);
142 # These are a set of options which are common to all of these functions
144 my %common_options = (debug => {type => SCALARREF|HANDLE,
147 transcript => {type => SCALARREF|HANDLE,
150 affected_bugs => {type => HASHREF,
153 affected_packages => {type => HASHREF,
156 recipients => {type => HASHREF,
159 limit => {type => HASHREF,
162 show_bug_info => {type => BOOLEAN,
165 request_subject => {type => SCALAR,
166 default => 'Unknown Subject',
168 request_msgid => {type => SCALAR,
171 request_nn => {type => SCALAR,
174 request_replyto => {type => SCALAR,
177 locks => {type => HASHREF,
183 my %append_action_options =
184 (action => {type => SCALAR,
187 requester => {type => SCALAR,
190 request_addr => {type => SCALAR,
193 location => {type => SCALAR,
196 message => {type => SCALAR|ARRAYREF,
199 append_log => {type => BOOLEAN,
201 depends => [qw(requester request_addr),
205 # locks is both an append_action option, and a common option;
206 # it's ok for it to be in both places.
207 locks => {type => HASHREF,
215 # this is just a generic stub for Debbugs::Control functions.
220 # set_foo(bug => $ref,
221 # transcript => $transcript,
222 # ($dl > 0 ? (debug => $transcript):()),
223 # requester => $header{from},
224 # request_addr => $controlrequestaddr,
226 # affected_packages => \%affected_packages,
227 # recipients => \%recipients,
233 # print {$transcript} "Failed to set foo $ref bar: $@";
241 # my %param = validate_with(params => \@_,
242 # spec => {bug => {type => SCALAR,
243 # regex => qr/^\d+$/,
245 # # specific options here
247 # %append_action_options,
251 # __begin_control(%param,
254 # my ($debug,$transcript) =
255 # @info{qw(debug transcript)};
256 # my @data = @{$info{data}};
257 # my @bugs = @{$info{bugs}};
260 # for my $data (@data) {
261 # append_action_to_log(bug => $data->{bug_num},
263 # __return_append_to_log_options(
268 # if not exists $param{append_log} or $param{append_log};
269 # writebug($data->{bug_num},$data);
270 # print {$transcript} "$action\n";
272 # __end_control(%info);
279 set_block(bug => $ref,
280 transcript => $transcript,
281 ($dl > 0 ? (debug => $transcript):()),
282 requester => $header{from},
283 request_addr => $controlrequestaddr,
285 affected_packages => \%affected_packages,
286 recipients => \%recipients,
292 print {$transcript} "Failed to set blockers of $ref: $@";
295 Alters the set of bugs that block this bug from being fixed
297 This requires altering both this bug (and those it's merged with) as
298 well as the bugs that block this bug from being fixed (and those that
303 =item block -- scalar or arrayref of blocking bugs to set, add or remove
305 =item add -- if true, add blocking bugs
307 =item remove -- if true, remove blocking bugs
314 my %param = validate_with(params => \@_,
315 spec => {bug => {type => SCALAR,
318 # specific options here
319 block => {type => SCALAR|ARRAYREF,
322 add => {type => BOOLEAN,
325 remove => {type => BOOLEAN,
329 %append_action_options,
332 if ($param{add} and $param{remove}) {
333 croak "It's nonsensical to add and remove the same blocking bugs";
335 if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
336 croak "Invalid blocking bug(s):".
337 join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
343 elsif ($param{remove}) {
348 __begin_control(%param,
351 my ($debug,$transcript) =
352 @info{qw(debug transcript)};
353 my @data = @{$info{data}};
354 my @bugs = @{$info{bugs}};
357 # The first bit of this code is ugly, and should be cleaned up.
358 # Its purpose is to populate %removed_blockers and %add_blockers
359 # with all of the bugs that should be added or removed as blockers
360 # of all of the bugs which are merged with $param{bug}
363 for my $blocker (make_list($param{block})) {
364 next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
365 my $data = read_bug(bug=>$blocker,
367 if (defined $data and not $data->{archive}) {
368 $data = split_status_fields($data);
369 $ok_blockers{$blocker} = 1;
371 push @merged_bugs, make_list($data->{mergedwith});
372 @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
375 $bad_blockers{$blocker} = 1;
379 # throw an error if we are setting the blockers and there is a bad
381 if (keys %bad_blockers and $mode eq 'set') {
382 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
383 keys %ok_blockers?'':" and no known blocking bug(s)";
385 # if there are no ok blockers and we are not setting the blockers,
387 if (not keys %ok_blockers and $mode ne 'set') {
388 print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
389 if (keys %bad_blockers) {
390 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
392 __end_control(%info);
396 my @change_blockers = keys %ok_blockers;
398 my %removed_blockers;
401 my @blockers = map {split ' ', $_->{blockedby}} @data;
403 @blockers{@blockers} = (1) x @blockers;
405 # it is nonsensical for a bug to block itself (or a merged
406 # partner); We currently don't allow removal because we'd possibly
410 @bugs{@bugs} = (1) x @bugs;
411 for my $blocker (@change_blockers) {
412 if ($bugs{$blocker}) {
413 croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
416 @blockers = keys %blockers;
418 %removed_blockers = ();
419 for my $blocker (@change_blockers) {
420 next if exists $blockers{$blocker};
421 $blockers{$blocker} = 1;
422 $added_blockers{$blocker} = 1;
425 elsif ($param{remove}) {
426 %added_blockers = ();
427 for my $blocker (@change_blockers) {
428 next if exists $removed_blockers{$blocker};
429 delete $blockers{$blocker};
430 $removed_blockers{$blocker} = 1;
434 @removed_blockers{@blockers} = (1) x @blockers;
436 for my $blocker (@change_blockers) {
437 next if exists $blockers{$blocker};
438 $blockers{$blocker} = 1;
439 if (exists $removed_blockers{$blocker}) {
440 delete $removed_blockers{$blocker};
443 $added_blockers{$blocker} = 1;
447 my @new_blockers = keys %blockers;
448 for my $data (@data) {
449 my $old_data = dclone($data);
450 # remove blockers and/or add new ones as appropriate
451 if ($data->{blockedby} eq '') {
452 print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n";
454 print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n";
456 if ($data->{blocks} eq '') {
457 print {$transcript} "$data->{bug_num} was not blocking any bugs.\n";
459 print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n";
462 push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
463 push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers;
464 $action = ucfirst(join ('; ',@changed)) if @changed;
466 print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n";
469 $data->{blockedby} = join(' ',keys %blockers);
470 append_action_to_log(bug => $data->{bug_num},
472 old_data => $old_data,
475 __return_append_to_log_options(
480 if not exists $param{append_log} or $param{append_log};
481 writebug($data->{bug_num},$data);
482 print {$transcript} "$action\n";
484 # we do this bit below to avoid code duplication
486 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
487 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
489 for my $add_remove (keys %mungable_blocks) {
493 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
494 next if $munge_blockers{$blocker};
495 my ($temp_locks, @blocking_data) =
496 lock_read_all_merged_bugs(bug => $blocker,
497 ($param{archived}?(location => 'archive'):()),
498 exists $param{locks}?(locks => $param{locks}):(),
500 $locks+= $temp_locks;
501 $new_locks+=$temp_locks;
502 if (not @blocking_data) {
503 for (1..$new_locks) {
504 unfilelock(exists $param{locks}?$param{locks}:());
507 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
509 for (map {$_->{bug_num}} @blocking_data) {
510 $munge_blockers{$_} = 1;
512 for my $data (@blocking_data) {
513 my $old_data = dclone($data);
515 my @blocks = split ' ', $data->{blocks};
516 @blocks{@blocks} = (1) x @blocks;
518 for my $bug (@bugs) {
519 if ($add_remove eq 'remove') {
520 next unless exists $blocks{$bug};
521 delete $blocks{$bug};
524 next if exists $blocks{$bug};
529 $data->{blocks} = join(' ',sort keys %blocks);
530 my $action = ($add_remove eq 'add'?'Added':'Removed').
531 " indication that bug $data->{bug_num} blocks ".
533 append_action_to_log(bug => $data->{bug_num},
535 old_data => $old_data,
538 __return_append_to_log_options(%param,
542 writebug($data->{bug_num},$data);
544 __handle_affected_packages(%param,data=>\@blocking_data);
545 add_recipients(recipients => $param{recipients},
546 actions_taken => {blocks => 1},
547 data => \@blocking_data,
549 transcript => $transcript,
552 for (1..$new_locks) {
553 unfilelock(exists $param{locks}?$param{locks}:());
558 __end_control(%info);
567 transcript => $transcript,
568 ($dl > 0 ? (debug => $transcript):()),
569 requester => $header{from},
570 request_addr => $controlrequestaddr,
572 affected_packages => \%affected_packages,
573 recipients => \%recipients,
580 print {$transcript} "Failed to set tag on $ref: $@";
584 Sets, adds, or removes the specified tags on a bug
588 =item tag -- scalar or arrayref of tags to set, add or remove
590 =item add -- if true, add tags
592 =item remove -- if true, remove tags
594 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
602 my %param = validate_with(params => \@_,
603 spec => {bug => {type => SCALAR,
606 # specific options here
607 tag => {type => SCALAR|ARRAYREF,
610 add => {type => BOOLEAN,
613 remove => {type => BOOLEAN,
616 warn_on_bad_tags => {type => BOOLEAN,
620 %append_action_options,
623 if ($param{add} and $param{remove}) {
624 croak "It's nonsensical to add and remove the same tags";
628 __begin_control(%param,
631 my ($debug,$transcript) =
632 @info{qw(debug transcript)};
633 my @data = @{$info{data}};
634 my @bugs = @{$info{bugs}};
635 my @tags = make_list($param{tag});
636 if (not @tags and ($param{remove} or $param{add})) {
637 if ($param{remove}) {
638 print {$transcript} "Requested to remove no tags; doing nothing.\n";
641 print {$transcript} "Requested to add no tags; doing nothing.\n";
643 __end_control(%info);
646 # first things first, make the versions fully qualified source
648 for my $data (@data) {
649 my $action = 'Did not alter tags';
651 my %tag_removed = ();
652 my %fixed_removed = ();
653 my @old_tags = split /\,?\s+/, $data->{keywords};
655 @tags{@old_tags} = (1) x @old_tags;
657 my $old_data = dclone($data);
658 if (not $param{add} and not $param{remove}) {
659 $tag_removed{$_} = 1 for @old_tags;
663 for my $tag (@tags) {
664 if (not $param{remove} and
665 not defined first {$_ eq $tag} @{$config{tags}}) {
666 push @bad_tags, $tag;
670 if (not exists $tags{$tag}) {
672 $tag_added{$tag} = 1;
675 elsif ($param{remove}) {
676 if (exists $tags{$tag}) {
678 $tag_removed{$tag} = 1;
682 if (exists $tag_removed{$tag}) {
683 delete $tag_removed{$tag};
686 $tag_added{$tag} = 1;
691 if (@bad_tags and $param{warn_on_bad_tags}) {
692 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
693 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
695 $data->{keywords} = join(' ',keys %tags);
698 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
699 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
700 $action = ucfirst(join ('; ',@changed)) if @changed;
702 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n";
706 append_action_to_log(bug => $data->{bug_num},
709 old_data => $old_data,
711 __return_append_to_log_options(
716 if not exists $param{append_log} or $param{append_log};
717 writebug($data->{bug_num},$data);
718 print {$transcript} "$action\n";
720 __end_control(%info);
728 set_severity(bug => $ref,
729 transcript => $transcript,
730 ($dl > 0 ? (debug => $transcript):()),
731 requester => $header{from},
732 request_addr => $controlrequestaddr,
734 affected_packages => \%affected_packages,
735 recipients => \%recipients,
736 severity => 'normal',
741 print {$transcript} "Failed to set the severity of bug $ref: $@";
744 Sets the severity of a bug. If severity is not passed, is undefined,
745 or has zero length, sets the severity to the default severity.
750 my %param = validate_with(params => \@_,
751 spec => {bug => {type => SCALAR,
754 # specific options here
755 severity => {type => SCALAR|UNDEF,
756 default => $config{default_severity},
759 %append_action_options,
762 if (not defined $param{severity} or
763 not length $param{severity}
765 $param{severity} = $config{default_severity};
768 # check validity of new severity
769 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
770 die "Severity '$param{severity}' is not a valid severity level";
773 __begin_control(%param,
774 command => 'severity'
776 my ($debug,$transcript) =
777 @info{qw(debug transcript)};
778 my @data = @{$info{data}};
779 my @bugs = @{$info{bugs}};
782 for my $data (@data) {
783 if (not defined $data->{severity}) {
784 $data->{severity} = $param{severity};
785 $action = "Severity set to '$param{severity}'";
788 if ($data->{severity} eq '') {
789 $data->{severity} = $config{default_severity};
791 if ($data->{severity} eq $param{severity}) {
792 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
795 $action = "Severity set to '$param{severity}' from '$data->{severity}'";
796 $data->{severity} = $param{severity};
798 append_action_to_log(bug => $data->{bug_num},
800 __return_append_to_log_options(
805 if not exists $param{append_log} or $param{append_log};
806 writebug($data->{bug_num},$data);
807 print {$transcript} "$action\n";
809 __end_control(%info);
816 set_done(bug => $ref,
817 transcript => $transcript,
818 ($dl > 0 ? (debug => $transcript):()),
819 requester => $header{from},
820 request_addr => $controlrequestaddr,
822 affected_packages => \%affected_packages,
823 recipients => \%recipients,
828 print {$transcript} "Failed to set foo $ref bar: $@";
836 my %param = validate_with(params => \@_,
837 spec => {bug => {type => SCALAR,
840 reopen => {type => BOOLEAN,
843 submitter => {type => SCALAR,
846 clear_fixed => {type => BOOLEAN,
849 notify_submitter => {type => BOOLEAN,
852 original_report => {type => SCALARREF,
855 done => {type => SCALAR|UNDEF,
859 %append_action_options,
863 if (exists $param{submitter} and
864 not Mail::RFC822::Address::valid($param{submitter})) {
865 die "New submitter address '$param{submitter}' is not a valid e-mail address";
867 if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address
868 $param{done} = $param{requester};
870 if (exists $param{done} and
871 (not defined $param{done} or
872 not length $param{done})) {
878 __begin_control(%param,
879 command => $param{reopen}?'reopen':'done',
881 my ($debug,$transcript) =
882 @info{qw(debug transcript)};
883 my @data = @{$info{data}};
884 my @bugs = @{$info{bugs}};
887 if ($param{reopen}) {
888 # avoid warning multiple times if there are fixed versions
890 for my $data (@data) {
891 if (not exists $data->{done} or
892 not defined $data->{done} or
893 not length $data->{done}) {
894 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
895 __end_control(%info);
898 if (@{$data->{fixed_versions}} and $warn_fixed) {
899 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
900 print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n";
904 $action = "Bug reopened";
905 for my $data (@data) {
906 my $old_data = dclone($data);
908 append_action_to_log(bug => $data->{bug_num},
911 old_data => $old_data,
913 __return_append_to_log_options(
918 if not exists $param{append_log} or $param{append_log};
919 writebug($data->{bug_num},$data);
921 print {$transcript} "$action\n";
922 __end_control(%info);
923 if (exists $param{submitter}) {
924 set_submitter(bug => $param{bug},
925 submitter => $param{submitter},
927 keys %common_options,
928 keys %append_action_options)
931 # clear the fixed revisions
932 if ($param{clear_fixed}) {
933 set_fixed(fixed => [],
937 keys %common_options,
938 keys %append_action_options),
943 my %submitter_notified;
944 my $requester_notified = 0;
945 my $orig_report_set = 0;
946 for my $data (@data) {
947 if (exists $data->{done} and
948 defined $data->{done} and
949 length $data->{done}) {
950 print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
951 __end_control(%info);
955 for my $data (@data) {
956 my $old_data = dclone($data);
957 my $hash = get_hashname($data->{bug_num});
958 my $report_fh = IO::File->new("$config{spool_dir}/db-h/$hash/$data->{bug_num}.report",'r') or
959 die "Unable to open original report $config{spool_dir}/db-h/$hash/$data->{bug_num}.report for reading: $!";
963 $orig_report= <$report_fh>;
966 if (not $orig_report_set and defined $orig_report and
967 length $orig_report and
968 exists $param{original_report}){
969 ${$param{original_report}} = $orig_report;
970 $orig_report_set = 1;
973 $action = "Marked $config{bug} as done";
975 # set done to the requester
976 $data->{done} = exists $param{done}?$param{done}:$param{requester};
977 append_action_to_log(bug => $data->{bug_num},
980 old_data => $old_data,
982 __return_append_to_log_options(
987 if not exists $param{append_log} or $param{append_log};
988 writebug($data->{bug_num},$data);
989 print {$transcript} "$action\n";
990 # get the original report
991 if ($param{notify_submitter}) {
992 my $submitter_message;
993 if(not exists $submitter_notified{$data->{originator}}) {
995 create_mime_message([default_headers(queue_file => $param{request_nn},
997 msgid => $param{request_msgid},
998 msgtype => 'notifdone',
999 pr_msg => 'they-closed',
1001 [To => $data->{submitter},
1002 Subject => "$config{ubug}#$data->{bug_num} ".
1003 "closed by $param{requester} ".(defined $param{request_subject}?"($param{request_subject})":""),
1007 __message_body_template('mail/process_your_bug_done',
1009 replyto => (exists $param{request_replyto} ?
1010 $param{request_replyto} :
1011 $param{requester} || 'Unknown'),
1012 markedby => $param{requester},
1013 subject => $param{request_subject},
1014 messageid => $param{request_msgid},
1017 [join('',make_list($param{message})),$orig_report]
1019 send_mail_message(message => $submitter_message,
1020 recipients => $old_data->{submitter},
1022 $submitter_notified{$data->{originator}} = $submitter_message;
1025 $submitter_message = $submitter_notified{$data->{originator}};
1027 append_action_to_log(bug => $data->{bug_num},
1028 action => "Notification sent",
1030 request_addr => $data->{originator},
1031 desc => "$config{bug} acknowledged by developer.",
1032 recips => [$data->{originator}],
1033 message => $submitter_message,
1038 __end_control(%info);
1039 if (exists $param{fixed}) {
1040 set_fixed(fixed => $param{fixed},
1044 keys %common_options,
1045 keys %append_action_options
1053 =head2 set_submitter
1056 set_submitter(bug => $ref,
1057 transcript => $transcript,
1058 ($dl > 0 ? (debug => $transcript):()),
1059 requester => $header{from},
1060 request_addr => $controlrequestaddr,
1062 affected_packages => \%affected_packages,
1063 recipients => \%recipients,
1064 submitter => $new_submitter,
1065 notify_submitter => 1,
1070 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1073 Sets the submitter of a bug. If notify_submitter is true (the
1074 default), notifies the old submitter of a bug on changes
1079 my %param = validate_with(params => \@_,
1080 spec => {bug => {type => SCALAR,
1083 # specific options here
1084 submitter => {type => SCALAR,
1086 notify_submitter => {type => BOOLEAN,
1090 %append_action_options,
1093 if (not Mail::RFC822::Address::valid($param{submitter})) {
1094 die "New submitter address $param{submitter} is not a valid e-mail address";
1097 __begin_control(%param,
1098 command => 'submitter'
1100 my ($debug,$transcript) =
1101 @info{qw(debug transcript)};
1102 my @data = @{$info{data}};
1103 my @bugs = @{$info{bugs}};
1105 # here we only concern ourselves with the first of the merged bugs
1106 for my $data ($data[0]) {
1107 my $notify_old_submitter = 0;
1108 my $old_data = dclone($data);
1109 print {$debug} "Going to change bug submitter\n";
1110 if (((not defined $param{submitter} or not length $param{submitter}) and
1111 (not defined $data->{originator} or not length $data->{originator})) or
1112 (defined $param{submitter} and defined $data->{originator} and
1113 $param{submitter} eq $data->{originator})) {
1114 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n";
1118 if (defined $data->{originator} and length($data->{originator})) {
1119 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'.";
1120 $notify_old_submitter = 1;
1123 $action= "Set $config{bug} submitter to '$param{submitter}'.";
1125 $data->{originator} = $param{submitter};
1127 append_action_to_log(bug => $data->{bug_num},
1128 command => 'submitter',
1130 old_data => $old_data,
1132 __return_append_to_log_options(
1137 if not exists $param{append_log} or $param{append_log};
1138 writebug($data->{bug_num},$data);
1139 print {$transcript} "$action\n";
1140 # notify old submitter
1141 if ($notify_old_submitter and $param{notify_submitter}) {
1142 send_mail_message(message =>
1143 create_mime_message([default_headers(queue_file => $param{request_nn},
1145 msgid => $param{request_msgid},
1147 pr_msg => 'submitter-changed',
1149 [To => $old_data->{submitter},
1150 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
1154 __message_body_template('mail/submitter_changed',
1155 {old_data => $old_data,
1157 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
1161 recipients => $old_data->{submitter},
1165 __end_control(%info);
1170 =head2 set_forwarded
1173 set_forwarded(bug => $ref,
1174 transcript => $transcript,
1175 ($dl > 0 ? (debug => $transcript):()),
1176 requester => $header{from},
1177 request_addr => $controlrequestaddr,
1179 affected_packages => \%affected_packages,
1180 recipients => \%recipients,
1181 forwarded => $forward_to,
1186 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1189 Sets the location to which a bug is forwarded. Given an undef
1190 forwarded, unsets forwarded.
1196 my %param = validate_with(params => \@_,
1197 spec => {bug => {type => SCALAR,
1200 # specific options here
1201 forwarded => {type => SCALAR|UNDEF,
1204 %append_action_options,
1207 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1208 die "Non-printable characters are not allowed in the forwarded field";
1210 $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
1212 __begin_control(%param,
1213 command => 'forwarded'
1215 my ($debug,$transcript) =
1216 @info{qw(debug transcript)};
1217 my @data = @{$info{data}};
1218 my @bugs = @{$info{bugs}};
1220 for my $data (@data) {
1221 my $old_data = dclone($data);
1222 print {$debug} "Going to change bug forwarded\n";
1223 if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
1224 (not defined $param{forwarded} and
1225 defined $data->{forwarded} and not length $data->{forwarded})) {
1226 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n";
1230 if (not defined $param{forwarded}) {
1231 $action= "Unset $config{bug} forwarded-to-address";
1233 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1234 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'.";
1237 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1239 $data->{forwarded} = $param{forwarded};
1241 append_action_to_log(bug => $data->{bug_num},
1242 command => 'forwarded',
1244 old_data => $old_data,
1246 __return_append_to_log_options(
1251 if not exists $param{append_log} or $param{append_log};
1252 writebug($data->{bug_num},$data);
1253 print {$transcript} "$action\n";
1255 __end_control(%info);
1264 set_title(bug => $ref,
1265 transcript => $transcript,
1266 ($dl > 0 ? (debug => $transcript):()),
1267 requester => $header{from},
1268 request_addr => $controlrequestaddr,
1270 affected_packages => \%affected_packages,
1271 recipients => \%recipients,
1272 title => $new_title,
1277 print {$transcript} "Failed to set the title of $ref: $@";
1280 Sets the title of a specific bug
1286 my %param = validate_with(params => \@_,
1287 spec => {bug => {type => SCALAR,
1290 # specific options here
1291 title => {type => SCALAR,
1294 %append_action_options,
1297 if ($param{title} =~ /[^[:print:]]/) {
1298 die "Non-printable characters are not allowed in bug titles";
1301 my %info = __begin_control(%param,
1304 my ($debug,$transcript) =
1305 @info{qw(debug transcript)};
1306 my @data = @{$info{data}};
1307 my @bugs = @{$info{bugs}};
1309 for my $data (@data) {
1310 my $old_data = dclone($data);
1311 print {$debug} "Going to change bug title\n";
1312 if (defined $data->{subject} and length($data->{subject}) and
1313 $data->{subject} eq $param{title}) {
1314 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n";
1318 if (defined $data->{subject} and length($data->{subject})) {
1319 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'.";
1321 $action= "Set $config{bug} title to '$param{title}'.";
1323 $data->{subject} = $param{title};
1325 append_action_to_log(bug => $data->{bug_num},
1328 old_data => $old_data,
1330 __return_append_to_log_options(
1335 if not exists $param{append_log} or $param{append_log};
1336 writebug($data->{bug_num},$data);
1337 print {$transcript} "$action\n";
1339 __end_control(%info);
1346 set_package(bug => $ref,
1347 transcript => $transcript,
1348 ($dl > 0 ? (debug => $transcript):()),
1349 requester => $header{from},
1350 request_addr => $controlrequestaddr,
1352 affected_packages => \%affected_packages,
1353 recipients => \%recipients,
1354 package => $new_package,
1360 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1363 Indicates that a bug is in a particular package. If is_source is true,
1364 indicates that the package is a source package. [Internally, this
1365 causes src: to be prepended to the package name.]
1367 The default for is_source is 0. As a special case, if the package
1368 starts with 'src:', it is assumed to be a source package and is_source
1371 The package option must match the package_name_re regex.
1376 my %param = validate_with(params => \@_,
1377 spec => {bug => {type => SCALAR,
1380 # specific options here
1381 package => {type => SCALAR|ARRAYREF,
1383 is_source => {type => BOOLEAN,
1387 %append_action_options,
1390 my @new_packages = map {splitpackages($_)} make_list($param{package});
1391 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1392 croak "Invalid package name '".
1393 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1396 my %info = __begin_control(%param,
1397 command => 'package',
1399 my ($debug,$transcript) =
1400 @info{qw(debug transcript)};
1401 my @data = @{$info{data}};
1402 my @bugs = @{$info{bugs}};
1403 # clean up the new package
1407 ($temp =~ s/^src:// or
1408 $param{is_source}) ? 'src:'.$temp:$temp;
1412 my $package_reassigned = 0;
1413 for my $data (@data) {
1414 my $old_data = dclone($data);
1415 print {$debug} "Going to change assigned package\n";
1416 if (defined $data->{package} and length($data->{package}) and
1417 $data->{package} eq $new_package) {
1418 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n";
1422 if (defined $data->{package} and length($data->{package})) {
1423 $package_reassigned = 1;
1424 $action= "$config{bug} reassigned from package '$data->{package}'".
1425 " to '$new_package'.";
1427 $action= "$config{bug} assigned to package '$new_package'.";
1429 $data->{package} = $new_package;
1431 append_action_to_log(bug => $data->{bug_num},
1432 command => 'package',
1434 old_data => $old_data,
1436 __return_append_to_log_options(
1441 if not exists $param{append_log} or $param{append_log};
1442 writebug($data->{bug_num},$data);
1443 print {$transcript} "$action\n";
1445 __end_control(%info);
1446 # Only clear the fixed/found versions if the package has been
1448 if ($package_reassigned) {
1449 my @params_for_found_fixed =
1450 map {exists $param{$_}?($_,$param{$_}):()}
1452 keys %common_options,
1453 keys %append_action_options,
1455 set_found(found => [],
1456 @params_for_found_fixed,
1458 set_fixed(fixed => [],
1459 @params_for_found_fixed,
1467 set_found(bug => $ref,
1468 transcript => $transcript,
1469 ($dl > 0 ? (debug => $transcript):()),
1470 requester => $header{from},
1471 request_addr => $controlrequestaddr,
1473 affected_packages => \%affected_packages,
1474 recipients => \%recipients,
1481 print {$transcript} "Failed to set found on $ref: $@";
1485 Sets, adds, or removes the specified found versions of a package
1487 If the version list is empty, and the bug is currently not "done",
1488 causes the done field to be cleared.
1490 If any of the versions added to found are greater than any version in
1491 which the bug is fixed (or when the bug is found and there are no
1492 fixed versions) the done field is cleared.
1497 my %param = validate_with(params => \@_,
1498 spec => {bug => {type => SCALAR,
1501 # specific options here
1502 found => {type => SCALAR|ARRAYREF,
1505 add => {type => BOOLEAN,
1508 remove => {type => BOOLEAN,
1512 %append_action_options,
1515 if ($param{add} and $param{remove}) {
1516 croak "It's nonsensical to add and remove the same versions";
1520 __begin_control(%param,
1523 my ($debug,$transcript) =
1524 @info{qw(debug transcript)};
1525 my @data = @{$info{data}};
1526 my @bugs = @{$info{bugs}};
1528 for my $version (make_list($param{found})) {
1529 next unless defined $version;
1530 $versions{$version} =
1531 [make_source_versions(package => [splitpackages($data[0]{package})],
1532 warnings => $transcript,
1535 versions => $version,
1538 # This is really ugly, but it's what we have to do
1539 if (not @{$versions{$version}}) {
1540 print {$transcript} "Unable to make a source version for version '$version'\n";
1543 if (not keys %versions and ($param{remove} or $param{add})) {
1544 if ($param{remove}) {
1545 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1548 print {$transcript} "Requested to add no versions; doing nothing.\n";
1550 __end_control(%info);
1553 # first things first, make the versions fully qualified source
1555 for my $data (@data) {
1556 # The 'done' field gets a bit weird with version tracking,
1557 # because a bug may be closed by multiple people in different
1558 # branches. Until we have something more flexible, we set it
1559 # every time a bug is fixed, and clear it when a bug is found
1560 # in a version greater than any version in which the bug is
1561 # fixed or when a bug is found and there is no fixed version
1562 my $action = 'Did not alter found versions';
1563 my %found_added = ();
1564 my %found_removed = ();
1565 my %fixed_removed = ();
1567 my $old_data = dclone($data);
1568 if (not $param{add} and not $param{remove}) {
1569 $found_removed{$_} = 1 for @{$data->{found_versions}};
1570 $data->{found_versions} = [];
1573 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1575 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1576 for my $version (keys %versions) {
1578 my @svers = @{$versions{$version}};
1582 elsif (not grep {$version eq $_} @svers) {
1583 # The $version was not equal to one of the source
1584 # versions, so it's probably unqualified (or just
1585 # wrong). Delete it, and use the source versions
1587 if (exists $found_versions{$version}) {
1588 delete $found_versions{$version};
1589 $found_removed{$version} = 1;
1592 for my $sver (@svers) {
1593 if (not exists $found_versions{$sver}) {
1594 $found_versions{$sver} = 1;
1595 $found_added{$sver} = 1;
1597 # if the found we are adding matches any fixed
1598 # versions, remove them
1599 my @temp = grep m{(^|/)\Q$sver\E$}, keys %fixed_versions;
1600 delete $fixed_versions{$_} for @temp;
1601 $fixed_removed{$_} = 1 for @temp;
1604 # We only care about reopening the bug if the bug is
1606 if (defined $data->{done} and length $data->{done}) {
1607 my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
1609 # determine if we need to reopen
1610 my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
1611 keys %fixed_versions);
1612 if (not @fixed_order or
1613 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1619 elsif ($param{remove}) {
1620 # in the case of removal, we only concern ourself with
1621 # the version passed, not the source version it maps
1623 my @temp = grep m{(?:^|/)\Q$version\E$}, keys %found_versions;
1624 delete $found_versions{$_} for @temp;
1625 $found_removed{$_} = 1 for @temp;
1628 # set the keys to exactly these values
1629 my @svers = @{$versions{$version}};
1633 for my $sver (@svers) {
1634 if (not exists $found_versions{$sver}) {
1635 $found_versions{$sver} = 1;
1636 if (exists $found_removed{$sver}) {
1637 delete $found_removed{$sver};
1640 $found_added{$sver} = 1;
1647 $data->{found_versions} = [keys %found_versions];
1648 $data->{fixed_versions} = [keys %fixed_versions];
1651 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1652 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1653 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1654 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1655 $action = ucfirst(join ('; ',@changed)) if @changed;
1657 $action .= " and reopened"
1659 if (not $reopened and not @changed) {
1660 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n";
1664 append_action_to_log(bug => $data->{bug_num},
1667 old_data => $old_data,
1669 __return_append_to_log_options(
1674 if not exists $param{append_log} or $param{append_log};
1675 writebug($data->{bug_num},$data);
1676 print {$transcript} "$action\n";
1678 __end_control(%info);
1684 set_fixed(bug => $ref,
1685 transcript => $transcript,
1686 ($dl > 0 ? (debug => $transcript):()),
1687 requester => $header{from},
1688 request_addr => $controlrequestaddr,
1690 affected_packages => \%affected_packages,
1691 recipients => \%recipients,
1699 print {$transcript} "Failed to set fixed on $ref: $@";
1703 Sets, adds, or removes the specified fixed versions of a package
1705 If the fixed versions are empty (or end up being empty after this
1706 call) or the greatest fixed version is less than the greatest found
1707 version and the reopen option is true, the bug is reopened.
1709 This function is also called by the reopen function, which causes all
1710 of the fixed versions to be cleared.
1715 my %param = validate_with(params => \@_,
1716 spec => {bug => {type => SCALAR,
1719 # specific options here
1720 fixed => {type => SCALAR|ARRAYREF,
1723 add => {type => BOOLEAN,
1726 remove => {type => BOOLEAN,
1729 reopen => {type => BOOLEAN,
1733 %append_action_options,
1736 if ($param{add} and $param{remove}) {
1737 croak "It's nonsensical to add and remove the same versions";
1740 __begin_control(%param,
1743 my ($debug,$transcript) =
1744 @info{qw(debug transcript)};
1745 my @data = @{$info{data}};
1746 my @bugs = @{$info{bugs}};
1748 for my $version (make_list($param{fixed})) {
1749 next unless defined $version;
1750 $versions{$version} =
1751 [make_source_versions(package => [splitpackages($data[0]{package})],
1752 warnings => $transcript,
1755 versions => $version,
1758 # This is really ugly, but it's what we have to do
1759 if (not @{$versions{$version}}) {
1760 print {$transcript} "Unable to make a source version for version '$version'\n";
1763 if (not keys %versions and ($param{remove} or $param{add})) {
1764 if ($param{remove}) {
1765 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1768 print {$transcript} "Requested to add no versions; doing nothing.\n";
1770 __end_control(%info);
1773 # first things first, make the versions fully qualified source
1775 for my $data (@data) {
1776 my $old_data = dclone($data);
1777 # The 'done' field gets a bit weird with version tracking,
1778 # because a bug may be closed by multiple people in different
1779 # branches. Until we have something more flexible, we set it
1780 # every time a bug is fixed, and clear it when a bug is found
1781 # in a version greater than any version in which the bug is
1782 # fixed or when a bug is found and there is no fixed version
1783 my $action = 'Did not alter fixed versions';
1784 my %found_added = ();
1785 my %found_removed = ();
1786 my %fixed_added = ();
1787 my %fixed_removed = ();
1789 if (not $param{add} and not $param{remove}) {
1790 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1791 $data->{fixed_versions} = [];
1794 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1796 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1797 for my $version (keys %versions) {
1799 my @svers = @{$versions{$version}};
1804 if (exists $fixed_versions{$version}) {
1805 $fixed_removed{$version} = 1;
1806 delete $fixed_versions{$version};
1809 for my $sver (@svers) {
1810 if (not exists $fixed_versions{$sver}) {
1811 $fixed_versions{$sver} = 1;
1812 $fixed_added{$sver} = 1;
1816 elsif ($param{remove}) {
1817 # in the case of removal, we only concern ourself with
1818 # the version passed, not the source version it maps
1820 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1821 delete $fixed_versions{$_} for @temp;
1822 $fixed_removed{$_} = 1 for @temp;
1825 # set the keys to exactly these values
1826 my @svers = @{$versions{$version}};
1830 for my $sver (@svers) {
1831 if (not exists $fixed_versions{$sver}) {
1832 $fixed_versions{$sver} = 1;
1833 if (exists $fixed_removed{$sver}) {
1834 delete $fixed_removed{$sver};
1837 $fixed_added{$sver} = 1;
1844 $data->{found_versions} = [keys %found_versions];
1845 $data->{fixed_versions} = [keys %fixed_versions];
1847 # If we're supposed to consider reopening, reopen if the
1848 # fixed versions are empty or the greatest found version
1849 # is greater than the greatest fixed version
1850 if ($param{reopen} and defined $data->{done}
1851 and length $data->{done}) {
1852 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1853 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1854 # determine if we need to reopen
1855 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1856 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1857 if (not @fixed_order or
1858 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1865 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1866 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1867 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1868 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1869 $action = ucfirst(join ('; ',@changed)) if @changed;
1871 $action .= " and reopened"
1873 if (not $reopened and not @changed) {
1874 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n";
1878 append_action_to_log(bug => $data->{bug_num},
1881 old_data => $old_data,
1883 __return_append_to_log_options(
1888 if not exists $param{append_log} or $param{append_log};
1889 writebug($data->{bug_num},$data);
1890 print {$transcript} "$action\n";
1892 __end_control(%info);
1899 set_merged(bug => $ref,
1900 transcript => $transcript,
1901 ($dl > 0 ? (debug => $transcript):()),
1902 requester => $header{from},
1903 request_addr => $controlrequestaddr,
1905 affected_packages => \%affected_packages,
1906 recipients => \%recipients,
1907 merge_with => 12345,
1910 allow_reassign => 1,
1911 reassign_same_source_only => 1,
1916 print {$transcript} "Failed to set merged on $ref: $@";
1920 Sets, adds, or removes the specified merged bugs of a bug
1922 By default, requires
1927 my %param = validate_with(params => \@_,
1928 spec => {bug => {type => SCALAR,
1931 # specific options here
1932 merge_with => {type => ARRAYREF|SCALAR,
1935 remove => {type => BOOLEAN,
1938 force => {type => BOOLEAN,
1941 masterbug => {type => BOOLEAN,
1944 allow_reassign => {type => BOOLEAN,
1947 reassign_different_sources => {type => BOOLEAN,
1951 %append_action_options,
1954 my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1956 @merging{@merging} = (1) x @merging;
1957 if (grep {$_ !~ /^\d+$/} @merging) {
1958 croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1960 $param{locks} = {} if not exists $param{locks};
1962 __begin_control(%param,
1965 my ($debug,$transcript) =
1966 @info{qw(debug transcript)};
1967 if (not @merging and exists $param{merge_with}) {
1968 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1969 __end_control(%info);
1972 my @data = @{$info{data}};
1973 my @bugs = @{$info{bugs}};
1976 for my $data (@data) {
1977 $data{$data->{bug_num}} = $data;
1978 my @merged_bugs = split / /, $data->{mergedwith};
1979 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1983 if (not exists $param{merge_with}) {
1984 my $ok_to_unmerge = 1;
1985 delete $merged_bugs{$param{bug}};
1986 if (not keys %merged_bugs) {
1987 print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1988 __end_control(%info);
1991 my $action = "Disconnected #$param{bug} from all other report(s).";
1992 for my $data (@data) {
1993 my $old_data = dclone($data);
1994 if ($data->{bug_num} == $param{bug}) {
1995 $data->{mergedwith} = '';
1998 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2001 append_action_to_log(bug => $data->{bug_num},
2004 old_data => $old_data,
2006 __return_append_to_log_options(%param,
2010 if not exists $param{append_log} or $param{append_log};
2011 writebug($data->{bug_num},$data);
2013 print {$transcript} "$action\n";
2014 __end_control(%info);
2017 # lock and load all of the bugs we need
2018 my @bugs_to_load = keys %merging;
2021 my ($data,$n_locks) =
2022 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2024 locks => $param{locks},
2027 $new_locks += $n_locks;
2029 @data = values %data;
2030 if (not check_limit(data => [@data],
2031 exists $param{limit}?(limit => $param{limit}):(),
2032 transcript => $transcript,
2034 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2036 for my $data (@data) {
2037 $data{$data->{bug_num}} = $data;
2038 $merged_bugs{$data->{bug_num}} = 1;
2039 my @merged_bugs = split / /, $data->{mergedwith};
2040 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2041 if (exists $param{affected_bugs}) {
2042 $param{affected_bugs}{$data->{bug_num}} = 1;
2045 __handle_affected_packages(%param,data => [@data]);
2046 my %bug_info_shown; # which bugs have had information shown
2047 $bug_info_shown{$param{bug}} = 1;
2048 add_recipients(data => [@data],
2049 recipients => $param{recipients},
2050 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2052 (__internal_request()?(transcript => $transcript):()),
2055 # Figure out what the ideal state is for the bug,
2056 my ($merge_status,$bugs_to_merge) =
2057 __calculate_merge_status(\@data,\%data,$param{bug});
2058 # find out if we actually have any bugs to merge
2059 if (not $bugs_to_merge) {
2060 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2061 for (1..$new_locks) {
2062 unfilelock($param{locks});
2065 __end_control(%info);
2068 # see what changes need to be made to merge the bugs
2069 # check to make sure that the set of changes we need to make is allowed
2070 my ($disallowed_changes,$changes) =
2071 __calculate_merge_changes(\@data,$merge_status,\%param);
2072 # at this point, stop if there are disallowed changes, otherwise
2073 # make the allowed changes, and then reread the bugs in question
2074 # to get the new data, then recaculate the merges; repeat
2075 # reloading and recalculating until we try too many times or there
2076 # are no changes to make.
2079 # we will allow at most 4 times through this; more than 1
2080 # shouldn't really happen.
2082 while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2083 if ($attempts > 1) {
2084 print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2086 if (@{$disallowed_changes}) {
2087 # figure out the problems
2088 print {$transcript} "Unable to merge bugs because:\n";
2089 for my $change (@{$disallowed_changes}) {
2090 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2092 if ($attempts > 0) {
2093 croak "Some bugs were altered while attempting to merge";
2096 croak "Did not alter merged bugs";
2099 my @bugs_to_change = keys %{$changes};
2100 for my $change_bug (@bugs_to_change) {
2101 next unless exists $changes->{$change_bug};
2102 $bug_changed{$change_bug}++;
2103 print {$transcript} __bug_info($data{$change_bug}) if
2104 $param{show_bug_info} and not __internal_request(1);
2105 $bug_info_shown{$change_bug} = 1;
2106 __allow_relocking($param{locks},[keys %data]);
2107 for my $change (@{$changes->{$change_bug}}) {
2108 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2109 my %target_blockedby;
2110 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2111 my %unhandled_targets = %target_blockedby;
2112 my @blocks_to_remove;
2113 for my $key (split / /,$change->{orig_value}) {
2114 delete $unhandled_targets{$key};
2115 next if exists $target_blockedby{$key};
2116 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2117 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2120 keys %common_options,
2121 keys %append_action_options),
2124 for my $key (keys %unhandled_targets) {
2125 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2126 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2129 keys %common_options,
2130 keys %append_action_options),
2135 $change->{function}->(bug => $change->{bug},
2136 $change->{key}, $change->{func_value},
2137 exists $change->{options}?@{$change->{options}}:(),
2139 keys %common_options,
2140 keys %append_action_options),
2144 __disallow_relocking($param{locks});
2145 my ($data,$n_locks) =
2146 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2148 locks => $param{locks},
2152 $new_locks += $n_locks;
2155 @data = values %data;
2156 ($merge_status,$bugs_to_merge) =
2157 __calculate_merge_status(\@data,\%data,$param{bug},$merge_status);
2158 ($disallowed_changes,$changes) =
2159 __calculate_merge_changes(\@data,$merge_status,\%param);
2160 $attempts = max(values %bug_changed);
2163 if ($param{show_bug_info} and not __internal_request(1)) {
2164 for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2165 next if $bug_info_shown{$data->{bug_num}};
2166 print {$transcript} __bug_info($data);
2169 if (keys %{$changes} or @{$disallowed_changes}) {
2170 print {$transcript} "After four attempts, the following changes were unable to be made:\n";
2171 for (1..$new_locks) {
2172 unfilelock($param{locks});
2175 __end_control(%info);
2176 for my $change ((map {@{$_}} values %{$changes}), @{$disallowed_changes}) {
2177 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2179 die "Unable to modify bugs so they could be merged";
2183 # finally, we can merge the bugs
2184 my $action = "Merged ".join(' ',sort keys %merged_bugs);
2185 for my $data (@data) {
2186 my $old_data = dclone($data);
2187 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2189 append_action_to_log(bug => $data->{bug_num},
2192 old_data => $old_data,
2194 __return_append_to_log_options(%param,
2198 if not exists $param{append_log} or $param{append_log};
2199 writebug($data->{bug_num},$data);
2201 print {$transcript} "$action\n";
2202 # unlock the extra locks that we got earlier
2203 for (1..$new_locks) {
2204 unfilelock($param{locks});
2207 __end_control(%info);
2210 sub __allow_relocking{
2211 my ($locks,$bugs) = @_;
2213 my @locks = (@{$bugs},'merge');
2214 for my $lock (@locks) {
2215 my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}};
2216 next unless @lockfiles;
2217 $locks->{relockable}{$lockfiles[0]} = 0;
2221 sub __disallow_relocking{
2223 delete $locks->{relockable};
2226 sub __lock_and_load_merged_bugs{
2228 validate_with(params => \@_,
2230 {bugs_to_load => {type => ARRAYREF,
2231 default => sub {[]},
2233 data => {type => HASHREF|ARRAYREF,
2235 locks => {type => HASHREF,
2236 default => sub {{};},
2238 reload_all => {type => BOOLEAN,
2241 debug => {type => HANDLE,
2247 if (ref($param{data}) eq 'ARRAY') {
2248 for my $data (@{$param{data}}) {
2249 $data{$data->{bug_num}} = dclone($data);
2253 %data = %{dclone($param{data})};
2255 my @bugs_to_load = @{$param{bugs_to_load}};
2256 if ($param{reload_all}) {
2257 push @bugs_to_load, keys %data;
2260 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2261 @bugs_to_load = keys %temp;
2262 my %loaded_this_time;
2264 while ($bug_to_load = shift @bugs_to_load) {
2265 if (not $param{reload_all}) {
2266 next if exists $data{$bug_to_load};
2269 next if $loaded_this_time{$bug_to_load};
2272 if ($param{reload_all}) {
2273 if (exists $data{$bug_to_load}) {
2278 read_bug(bug => $bug_to_load,
2280 locks => $param{locks},
2282 die "Unable to load bug $bug_to_load";
2283 print {$param{debug}} "read bug $bug_to_load\n";
2284 $data{$data->{bug_num}} = $data;
2285 $new_locks += $lock_bug;
2286 $loaded_this_time{$data->{bug_num}} = 1;
2288 grep {not exists $data{$_}}
2289 split / /,$data->{mergedwith};
2291 return (\%data,$new_locks);
2295 sub __calculate_merge_status{
2296 my ($data_a,$data_h,$master_bug,$merge_status) = @_;
2297 my %merge_status = %{$merge_status // {}};
2299 my $bugs_to_merge = 0;
2300 for my $data (@{$data_a}) {
2301 # check to see if this bug is unmerged in the set
2302 if (not length $data->{mergedwith} or
2303 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2304 $merged_bugs{$data->{bug_num}} = 1;
2307 # the master_bug is the bug that every other bug is made to
2308 # look like. However, if merge is set, tags, fixed and found
2310 if ($data->{bug_num} == $master_bug) {
2311 for (qw(package forwarded severity blocks blockedby done owner summary outlook affects)) {
2312 $merge_status{$_} = $data->{$_}
2315 if (defined $merge_status) {
2316 next unless $data->{bug_num} == $master_bug;
2318 $merge_status{tag} = {} if not exists $merge_status{tag};
2319 for my $tag (split /\s+/, $data->{keywords}) {
2320 $merge_status{tag}{$tag} = 1;
2322 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2323 for (qw(fixed found)) {
2324 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2327 # if there is a non-source qualified version with a corresponding
2328 # source qualified version, we only want to merge the source
2329 # qualified version(s)
2330 for (qw(fixed found)) {
2331 my @unqualified_versions = grep {m{/}?0:1} keys %{$merge_status{"${_}_versions"}};
2332 for my $unqualified_version (@unqualified_versions) {
2333 if (grep {m{/\Q$unqualified_version\E}} keys %{$merge_status{"${_}_versions"}}) {
2334 delete $merge_status{"${_}_versions"}{$unqualified_version};
2338 return (\%merge_status,$bugs_to_merge);
2343 sub __calculate_merge_changes{
2344 my ($datas,$merge_status,$param) = @_;
2346 my @disallowed_changes;
2347 for my $data (@{$datas}) {
2348 # things that can be forced
2350 # * func is the function to set the new value
2352 # * key is the key of the function to set the value,
2354 # * modify_value is a function which is called to modify the new
2355 # value so that the function will accept it
2357 # * options is an ARRAYREF of options to pass to the function
2359 # * allowed is a BOOLEAN which controls whether this setting
2360 # is allowed to be different by default.
2361 my %force_functions =
2362 (forwarded => {func => \&set_forwarded,
2366 severity => {func => \&set_severity,
2370 blocks => {func => \&set_blocks,
2371 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2375 blockedby => {func => \&set_blocks,
2376 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2380 done => {func => \&set_done,
2384 owner => {func => \&owner,
2388 summary => {func => \&summary,
2392 outlook => {func => \&outlook,
2396 affects => {func => \&affects,
2400 package => {func => \&set_package,
2404 keywords => {func => \&set_tag,
2406 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2409 fixed_versions => {func => \&set_fixed,
2411 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2414 found_versions => {func => \&set_found,
2416 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2420 for my $field (qw(forwarded severity blocks blockedby done owner summary outlook affects package fixed_versions found_versions keywords)) {
2421 # if the ideal bug already has the field set properly, we
2423 if ($field eq 'keywords'){
2424 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2425 join(' ',sort keys %{$merge_status->{tag}});
2427 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2428 next if join(' ', sort @{$data->{$field}}) eq
2429 join(' ',sort keys %{$merge_status->{$field}});
2431 elsif ($field eq 'done') {
2432 # for done, we only care if the bug is done or not
2433 # done, not the value it's set to.
2434 if (defined $merge_status->{$field} and length $merge_status->{$field} and
2435 defined $data->{$field} and length $data->{$field}) {
2438 elsif ((not defined $merge_status->{$field} or not length $merge_status->{$field}) and
2439 (not defined $data->{$field} or not length $data->{$field})
2444 elsif ($merge_status->{$field} eq $data->{$field}) {
2449 bug => $data->{bug_num},
2450 orig_value => $data->{$field},
2452 (exists $force_functions{$field}{modify_value} ?
2453 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2454 $merge_status->{$field}),
2455 value => $merge_status->{$field},
2456 function => $force_functions{$field}{func},
2457 key => $force_functions{$field}{key},
2458 options => $force_functions{$field}{options},
2459 allowed => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0,
2461 $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
2462 $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
2463 if ($param->{force} or $change->{allowed}) {
2464 if ($field ne 'package' or $change->{allowed}) {
2465 push @{$changes{$data->{bug_num}}},$change;
2468 if ($param->{allow_reassign}) {
2469 if ($param->{reassign_different_sources}) {
2470 push @{$changes{$data->{bug_num}}},$change;
2473 # allow reassigning if binary_to_source returns at
2474 # least one of the same source packages
2475 my @merge_status_source =
2476 binary_to_source(package => $merge_status->{package},
2479 my @other_bug_source =
2480 binary_to_source(package => $data->{package},
2483 my %merge_status_sources;
2484 @merge_status_sources{@merge_status_source} =
2485 (1) x @merge_status_source;
2486 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2487 push @{$changes{$data->{bug_num}}},$change;
2492 push @disallowed_changes,$change;
2494 # blocks and blocked by are weird; we have to go through and
2495 # set blocks to the other half of the merged bugs
2497 return (\@disallowed_changes,\%changes);
2503 affects(bug => $ref,
2504 transcript => $transcript,
2505 ($dl > 0 ? (debug => $transcript):()),
2506 requester => $header{from},
2507 request_addr => $controlrequestaddr,
2509 affected_packages => \%affected_packages,
2510 recipients => \%recipients,
2518 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2521 This marks a bug as affecting packages which the bug is not actually
2522 in. This should only be used in cases where fixing the bug instantly
2523 resolves the problem in the other packages.
2525 By default, the packages are set to the list of packages passed.
2526 However, if you pass add => 1 or remove => 1, the list of packages
2527 passed are added or removed from the affects list, respectively.
2532 my %param = validate_with(params => \@_,
2533 spec => {bug => {type => SCALAR,
2536 # specific options here
2537 package => {type => SCALAR|ARRAYREF|UNDEF,
2540 add => {type => BOOLEAN,
2543 remove => {type => BOOLEAN,
2547 %append_action_options,
2550 if ($param{add} and $param{remove}) {
2551 croak "Asking to both add and remove affects is nonsensical";
2553 if (not defined $param{package}) {
2554 $param{package} = [];
2557 __begin_control(%param,
2558 command => 'affects'
2560 my ($debug,$transcript) =
2561 @info{qw(debug transcript)};
2562 my @data = @{$info{data}};
2563 my @bugs = @{$info{bugs}};
2565 for my $data (@data) {
2567 print {$debug} "Going to change affects\n";
2568 my @packages = splitpackages($data->{affects});
2570 @packages{@packages} = (1) x @packages;
2573 for my $package (make_list($param{package})) {
2574 next unless defined $package and length $package;
2575 if (not $packages{$package}) {
2576 $packages{$package} = 1;
2577 push @added,$package;
2581 $action = "Added indication that $data->{bug_num} affects ".
2582 english_join(\@added);
2585 elsif ($param{remove}) {
2587 for my $package (make_list($param{package})) {
2588 if ($packages{$package}) {
2589 next unless defined $package and length $package;
2590 delete $packages{$package};
2591 push @removed,$package;
2594 $action = "Removed indication that $data->{bug_num} affects " .
2595 english_join(\@removed);
2598 my %added_packages = ();
2599 my %removed_packages = %packages;
2601 for my $package (make_list($param{package})) {
2602 next unless defined $package and length $package;
2603 $packages{$package} = 1;
2604 delete $removed_packages{$package};
2605 $added_packages{$package} = 1;
2607 if (keys %removed_packages) {
2608 $action = "Removed indication that $data->{bug_num} affects ".
2609 english_join([keys %removed_packages]);
2610 $action .= "\n" if keys %added_packages;
2612 if (keys %added_packages) {
2613 $action .= "Added indication that $data->{bug_num} affects " .
2614 english_join([keys %added_packages]);
2617 if (not length $action) {
2618 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n";
2621 my $old_data = dclone($data);
2622 $data->{affects} = join(',',keys %packages);
2623 append_action_to_log(bug => $data->{bug_num},
2625 command => 'affects',
2627 old_data => $old_data,
2628 __return_append_to_log_options(
2633 if not exists $param{append_log} or $param{append_log};
2634 writebug($data->{bug_num},$data);
2635 print {$transcript} "$action\n";
2637 __end_control(%info);
2641 =head1 SUMMARY FUNCTIONS
2646 summary(bug => $ref,
2647 transcript => $transcript,
2648 ($dl > 0 ? (debug => $transcript):()),
2649 requester => $header{from},
2650 request_addr => $controlrequestaddr,
2652 affected_packages => \%affected_packages,
2653 recipients => \%recipients,
2659 print {$transcript} "Failed to mark $ref with summary foo: $@";
2662 Handles all setting of summary fields
2664 If summary is undef, unsets the summary
2666 If summary is 0 or -1, sets the summary to the first paragraph contained in
2669 If summary is a positive integer, sets the summary to the message specified.
2671 Otherwise, sets summary to the value passed.
2677 # outlook and summary are exactly the same, basically
2678 return _summary('summary',@_);
2681 =head1 OUTLOOK FUNCTIONS
2686 outlook(bug => $ref,
2687 transcript => $transcript,
2688 ($dl > 0 ? (debug => $transcript):()),
2689 requester => $header{from},
2690 request_addr => $controlrequestaddr,
2692 affected_packages => \%affected_packages,
2693 recipients => \%recipients,
2699 print {$transcript} "Failed to mark $ref with outlook foo: $@";
2702 Handles all setting of outlook fields
2704 If outlook is undef, unsets the outlook
2706 If outlook is 0, sets the outlook to the first paragraph contained in
2709 If outlook is a positive integer, sets the outlook to the message specified.
2711 Otherwise, sets outlook to the value passed.
2717 return _summary('outlook',@_);
2721 my ($cmd,@params) = @_;
2722 my %param = validate_with(params => \@params,
2723 spec => {bug => {type => SCALAR,
2726 # specific options here
2727 $cmd , {type => SCALAR|UNDEF,
2731 %append_action_options,
2735 __begin_control(%param,
2738 my ($debug,$transcript) =
2739 @info{qw(debug transcript)};
2740 my @data = @{$info{data}};
2741 my @bugs = @{$info{bugs}};
2742 # figure out the log that we're going to use
2744 my $summary_msg = '';
2746 if (not defined $param{$cmd}) {
2748 print {$debug} "Removing $cmd fields\n";
2749 $action = "Removed $cmd";
2751 elsif ($param{$cmd} =~ /^\d+$/) {
2753 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2754 if ($param{$cmd} == 0 or $param{$cmd} == -1) {
2755 $log = $param{message};
2756 $summary_msg = @records + 1;
2759 if (($param{$cmd} - 1 ) > $#records) {
2760 die "Message number '$param{$cmd}' exceeds the maximum message '$#records'";
2762 my $record = $records[($param{$cmd} - 1 )];
2763 if ($record->{type} !~ /incoming-recv|recips/) {
2764 die "Message number '$param{$cmd}' is a invalid message type '$record->{type}'";
2766 $summary_msg = $param{$cmd};
2767 $log = [$record->{text}];
2769 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2770 my $body = $p_o->{body};
2771 my $in_pseudoheaders = 0;
2773 # walk through body until we get non-blank lines
2774 for my $line (@{$body}) {
2775 if ($line =~ /^\s*$/) {
2776 if (length $paragraph) {
2777 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2783 $in_pseudoheaders = 0;
2786 # skip a paragraph if it looks like it's control or
2788 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity|Control)\:\s+\S}xi or #pseudo headers
2789 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2790 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2791 debug|(?:not|)forwarded|priority|
2792 (?:un|)block|limit|(?:un|)archive|
2793 reassign|retitle|affects|wrongpackage
2794 (?:un|force|)merge|user(?:category|tags?|)
2796 if (not length $paragraph) {
2797 print {$debug} "Found control/pseudo-headers and skiping them\n";
2798 $in_pseudoheaders = 1;
2802 next if $in_pseudoheaders;
2803 $paragraph .= $line ." \n";
2805 print {$debug} ucfirst($cmd)." is going to be '$paragraph'\n";
2806 $summary = $paragraph;
2807 $summary =~ s/[\n\r]/ /g;
2808 if (not length $summary) {
2809 die "Unable to find $cmd message to use";
2811 # trim off a trailing spaces
2812 $summary =~ s/\ *$//;
2815 $summary = $param{$cmd};
2817 for my $data (@data) {
2818 print {$debug} "Going to change $cmd\n";
2819 if (((not defined $summary or not length $summary) and
2820 (not defined $data->{$cmd} or not length $data->{$cmd})) or
2821 $summary eq $data->{$cmd}) {
2822 print {$transcript} "Ignoring request to change the $cmd of bug $param{bug} to the same value\n";
2825 if (length $summary) {
2826 if (length $data->{$cmd}) {
2827 $action = ucfirst($cmd)." replaced with message bug $param{bug} message $summary_msg";
2830 $action = ucfirst($cmd)." recorded from message bug $param{bug} message $summary_msg";
2833 my $old_data = dclone($data);
2834 $data->{$cmd} = $summary;
2835 append_action_to_log(bug => $data->{bug_num},
2837 old_data => $old_data,
2840 __return_append_to_log_options(
2845 if not exists $param{append_log} or $param{append_log};
2846 writebug($data->{bug_num},$data);
2847 print {$transcript} "$action\n";
2849 __end_control(%info);
2857 clone_bug(bug => $ref,
2858 transcript => $transcript,
2859 ($dl > 0 ? (debug => $transcript):()),
2860 requester => $header{from},
2861 request_addr => $controlrequestaddr,
2863 affected_packages => \%affected_packages,
2864 recipients => \%recipients,
2869 print {$transcript} "Failed to clone bug $ref bar: $@";
2872 Clones the given bug.
2874 We currently don't support cloning merged bugs, but this could be
2875 handled by internally unmerging, cloning, then remerging the bugs.
2880 my %param = validate_with(params => \@_,
2881 spec => {bug => {type => SCALAR,
2884 new_bugs => {type => ARRAYREF,
2886 new_clones => {type => HASHREF,
2890 %append_action_options,
2894 __begin_control(%param,
2897 my ($debug,$transcript) =
2898 @info{qw(debug transcript)};
2899 my @data = @{$info{data}};
2900 my @bugs = @{$info{bugs}};
2903 for my $data (@data) {
2904 if (length($data->{mergedwith})) {
2905 die "Bug is marked as being merged with others. Use an existing clone.\n";
2909 die "Not exactly one bug‽ This shouldn't happen.";
2911 my $data = $data[0];
2913 for my $newclone_id (@{$param{new_bugs}}) {
2914 my $new_bug_num = new_bug(copy => $data->{bug_num});
2915 $param{new_clones}{$newclone_id} = $new_bug_num;
2916 $clones{$newclone_id} = $new_bug_num;
2918 my @new_bugs = sort values %clones;
2920 for my $new_bug (@new_bugs) {
2921 # no collapsed ids or the higher collapsed id is not one less
2922 # than the next highest new bug
2923 if (not @collapsed_ids or
2924 $collapsed_ids[-1][1]+1 != $new_bug) {
2925 push @collapsed_ids,[$new_bug,$new_bug];
2928 $collapsed_ids[-1][1] = $new_bug;
2932 for my $ci (@collapsed_ids) {
2933 if ($ci->[0] == $ci->[1]) {
2934 push @collapsed,$ci->[0];
2937 push @collapsed,$ci->[0].'-'.$ci->[1]
2940 my $collapsed_str = english_join(\@collapsed);
2941 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2942 for my $new_bug (@new_bugs) {
2943 append_action_to_log(bug => $new_bug,
2945 __return_append_to_log_options(
2950 if not exists $param{append_log} or $param{append_log};
2952 append_action_to_log(bug => $data->{bug_num},
2954 __return_append_to_log_options(
2959 if not exists $param{append_log} or $param{append_log};
2960 writebug($data->{bug_num},$data);
2961 print {$transcript} "$action\n";
2962 __end_control(%info);
2963 # bugs that this bug is blocking are also blocked by the new clone(s)
2964 for my $bug (split ' ', $data->{blocks}) {
2965 for my $new_bug (@new_bugs) {
2966 set_blocks(bug => $bug,
2969 keys %common_options,
2970 keys %append_action_options),
2974 # bugs that are blocking this bug are also blocking the new clone(s)
2975 for my $bug (split ' ', $data->{blockedby}) {
2976 for my $new_bug (@new_bugs) {
2977 set_blocks(bug => $new_bug,
2980 keys %common_options,
2981 keys %append_action_options),
2989 =head1 OWNER FUNCTIONS
2995 transcript => $transcript,
2996 ($dl > 0 ? (debug => $transcript):()),
2997 requester => $header{from},
2998 request_addr => $controlrequestaddr,
3000 recipients => \%recipients,
3006 print {$transcript} "Failed to mark $ref as having an owner: $@";
3009 Handles all setting of the owner field; given an owner of undef or of
3010 no length, indicates that a bug is not owned by anyone.
3015 my %param = validate_with(params => \@_,
3016 spec => {bug => {type => SCALAR,
3019 owner => {type => SCALAR|UNDEF,
3022 %append_action_options,
3026 __begin_control(%param,
3029 my ($debug,$transcript) =
3030 @info{qw(debug transcript)};
3031 my @data = @{$info{data}};
3032 my @bugs = @{$info{bugs}};
3034 for my $data (@data) {
3035 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
3036 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
3037 if (not defined $param{owner} or not length $param{owner}) {
3038 if (not defined $data->{owner} or not length $data->{owner}) {
3039 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n";
3043 $action = "Removed annotation that $config{bug} was owned by " .
3047 if ($data->{owner} eq $param{owner}) {
3048 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
3051 if (length $data->{owner}) {
3052 $action = "Owner changed from $data->{owner} to $param{owner}.";
3055 $action = "Owner recorded as $param{owner}."
3058 my $old_data = dclone($data);
3059 $data->{owner} = $param{owner};
3060 append_action_to_log(bug => $data->{bug_num},
3063 old_data => $old_data,
3065 __return_append_to_log_options(
3070 if not exists $param{append_log} or $param{append_log};
3071 writebug($data->{bug_num},$data);
3072 print {$transcript} "$action\n";
3074 __end_control(%info);
3078 =head1 ARCHIVE FUNCTIONS
3085 bug_archive(bug => $bug_num,
3087 transcript => \$transcript,
3092 transcript("Unable to archive $bug_num\n");
3095 transcript($transcript);
3098 This routine archives a bug
3102 =item bug -- bug number
3104 =item check_archiveable -- check wether a bug is archiveable before
3105 archiving; defaults to 1
3107 =item archive_unarchived -- whether to archive bugs which have not
3108 previously been archived; defaults to 1. [Set to 0 when used from
3111 =item ignore_time -- whether to ignore time constraints when archiving
3112 a bug; defaults to 0.
3119 my %param = validate_with(params => \@_,
3120 spec => {bug => {type => SCALAR,
3123 check_archiveable => {type => BOOLEAN,
3126 archive_unarchived => {type => BOOLEAN,
3129 ignore_time => {type => BOOLEAN,
3133 %append_action_options,
3136 my %info = __begin_control(%param,
3137 command => 'archive',
3139 my ($debug,$transcript) = @info{qw(debug transcript)};
3140 my @data = @{$info{data}};
3141 my @bugs = @{$info{bugs}};
3142 my $action = "$config{bug} archived.";
3143 if ($param{check_archiveable} and
3144 not bug_archiveable(bug=>$param{bug},
3145 ignore_time => $param{ignore_time},
3147 print {$transcript} "Bug $param{bug} cannot be archived\n";
3148 die "Bug $param{bug} cannot be archived";
3150 if (not $param{archive_unarchived} and
3151 not exists $data[0]{unarchived}
3153 print {$transcript} "$param{bug} has not been archived previously\n";
3154 die "$param{bug} has not been archived previously";
3156 add_recipients(recipients => $param{recipients},
3159 transcript => $transcript,
3161 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3162 for my $bug (@bugs) {
3163 if ($param{check_archiveable}) {
3164 die "Bug $bug cannot be archived (but $param{bug} can?)"
3165 unless bug_archiveable(bug=>$bug,
3166 ignore_time => $param{ignore_time},
3170 # If we get here, we can archive/remove this bug
3171 print {$debug} "$param{bug} removing\n";
3172 for my $bug (@bugs) {
3173 #print "$param{bug} removing $bug\n" if $debug;
3174 my $dir = get_hashname($bug);
3175 # First indicate that this bug is being archived
3176 append_action_to_log(bug => $bug,
3178 command => 'archive',
3179 # we didn't actually change the data
3180 # when we archived, so we don't pass
3181 # a real new_data or old_data
3184 __return_append_to_log_options(
3189 if not exists $param{append_log} or $param{append_log};
3190 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3191 if ($config{save_old_bugs}) {
3192 mkpath("$config{spool_dir}/archive/$dir");
3193 foreach my $file (@files_to_remove) {
3194 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3195 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3196 # we need to bail out here if things have
3197 # gone horribly wrong to avoid removing a
3199 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3202 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3204 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3205 print {$debug} "deleted $bug (from $param{bug})\n";
3207 bughook_archive(@bugs);
3208 __end_control(%info);
3211 =head2 bug_unarchive
3215 bug_unarchive(bug => $bug_num,
3217 transcript => \$transcript,
3222 transcript("Unable to archive bug: $bug_num");
3224 transcript($transcript);
3226 This routine unarchives a bug
3231 my %param = validate_with(params => \@_,
3232 spec => {bug => {type => SCALAR,
3236 %append_action_options,
3240 my %info = __begin_control(%param,
3242 command=>'unarchive');
3243 my ($debug,$transcript) =
3244 @info{qw(debug transcript)};
3245 my @data = @{$info{data}};
3246 my @bugs = @{$info{bugs}};
3247 my $action = "$config{bug} unarchived.";
3248 my @files_to_remove;
3249 for my $bug (@bugs) {
3250 print {$debug} "$param{bug} removing $bug\n";
3251 my $dir = get_hashname($bug);
3252 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3253 mkpath("archive/$dir");
3254 foreach my $file (@files_to_copy) {
3255 # die'ing here sucks
3256 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3257 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3258 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3260 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3261 print {$transcript} "Unarchived $config{bug} $bug\n";
3263 unlink(@files_to_remove) or die "Unable to unlink bugs";
3264 # Indicate that this bug has been archived previously
3265 for my $bug (@bugs) {
3266 my $newdata = readbug($bug);
3267 my $old_data = dclone($newdata);
3268 if (not defined $newdata) {
3269 print {$transcript} "$config{bug} $bug disappeared!\n";
3270 die "Bug $bug disappeared!";
3272 $newdata->{unarchived} = time;
3273 append_action_to_log(bug => $bug,
3275 command => 'unarchive',
3276 new_data => $newdata,
3277 old_data => $old_data,
3278 __return_append_to_log_options(
3283 if not exists $param{append_log} or $param{append_log};
3284 writebug($bug,$newdata);
3286 __end_control(%info);
3289 =head2 append_action_to_log
3291 append_action_to_log
3293 This should probably be moved to Debbugs::Log; have to think that out
3298 sub append_action_to_log{
3299 my %param = validate_with(params => \@_,
3300 spec => {bug => {type => SCALAR,
3303 new_data => {type => HASHREF,
3306 old_data => {type => HASHREF,
3309 command => {type => SCALAR,
3312 action => {type => SCALAR,
3314 requester => {type => SCALAR,
3317 request_addr => {type => SCALAR,
3320 location => {type => SCALAR,
3323 message => {type => SCALAR|ARRAYREF,
3326 recips => {type => SCALAR|ARRAYREF,
3329 desc => {type => SCALAR,
3332 get_lock => {type => BOOLEAN,
3335 locks => {type => HASHREF,
3339 # append_action_options here
3340 # because some of these
3341 # options aren't actually
3342 # optional, even though the
3343 # original function doesn't
3347 # Fix this to use $param{location}
3348 my $log_location = buglog($param{bug});
3349 die "Unable to find .log for $param{bug}"
3350 if not defined $log_location;
3351 if ($param{get_lock}) {
3352 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3356 my $logfh = IO::File->new(">>$log_location") or
3357 die "Unable to open $log_location for appending: $!";
3358 # determine difference between old and new
3360 if (exists $param{old_data} and exists $param{new_data}) {
3361 my $old_data = dclone($param{old_data});
3362 my $new_data = dclone($param{new_data});
3363 for my $key (keys %{$old_data}) {
3364 if (not exists $Debbugs::Status::fields{$key}) {
3365 delete $old_data->{$key};
3368 next unless exists $new_data->{$key};
3369 next unless defined $new_data->{$key};
3370 if (not defined $old_data->{$key}) {
3371 delete $old_data->{$key};
3374 if (ref($new_data->{$key}) and
3375 ref($old_data->{$key}) and
3376 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3377 local $Storable::canonical = 1;
3378 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3379 delete $new_data->{$key};
3380 delete $old_data->{$key};
3383 elsif ($new_data->{$key} eq $old_data->{$key}) {
3384 delete $new_data->{$key};
3385 delete $old_data->{$key};
3388 for my $key (keys %{$new_data}) {
3389 if (not exists $Debbugs::Status::fields{$key}) {
3390 delete $new_data->{$key};
3393 next unless exists $old_data->{$key};
3394 next unless defined $old_data->{$key};
3395 if (not defined $new_data->{$key} or
3396 not exists $Debbugs::Status::fields{$key}) {
3397 delete $new_data->{$key};
3400 if (ref($new_data->{$key}) and
3401 ref($old_data->{$key}) and
3402 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3403 local $Storable::canonical = 1;
3404 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3405 delete $new_data->{$key};
3406 delete $old_data->{$key};
3409 elsif ($new_data->{$key} eq $old_data->{$key}) {
3410 delete $new_data->{$key};
3411 delete $old_data->{$key};
3414 $data_diff .= "<!-- new_data:\n";
3416 for my $key (keys %{$new_data}) {
3417 if (not exists $Debbugs::Status::fields{$key}) {
3418 warn "No such field $key";
3421 $nd{$key} = $new_data->{$key};
3422 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3424 $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%nd)],[qw(new_data)]));
3425 $data_diff .= "-->\n";
3426 $data_diff .= "<!-- old_data:\n";
3428 for my $key (keys %{$old_data}) {
3429 if (not exists $Debbugs::Status::fields{$key}) {
3430 warn "No such field $key";
3433 $od{$key} = $old_data->{$key};
3434 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3436 $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%od)],[qw(old_data)]));
3437 $data_diff .= "-->\n";
3440 (exists $param{command} ?
3441 "<!-- command:".html_escape(encode_utf8_safely($param{command}))." -->\n":""
3443 (length $param{requester} ?
3444 "<!-- requester: ".html_escape(encode_utf8_safely($param{requester}))." -->\n":""
3446 (length $param{request_addr} ?
3447 "<!-- request_addr: ".html_escape(encode_utf8_safely($param{request_addr}))." -->\n":""
3449 "<!-- time:".time()." -->\n",
3451 "<strong>".html_escape(encode_utf8_safely($param{action}))."</strong>\n");
3452 if (length $param{requester}) {
3453 $msg .= "Request was from <code>".html_escape(encode_utf8_safely($param{requester}))."</code>\n";
3455 if (length $param{request_addr}) {
3456 $msg .= "to <code>".html_escape(encode_utf8_safely($param{request_addr}))."</code>";
3458 if (length $param{desc}) {
3459 $msg .= ":<br>\n".encode_utf8_safely($param{desc})."\n";
3464 push @records, {type => 'html',
3468 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3469 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3470 exists $param{recips}?(recips => [map {encode_utf8_safely($_)} make_list($param{recips})]):(),
3471 text => join('',make_list($param{message})),
3474 write_log_records(logfh=>$logfh,
3475 records => \@records,
3477 close $logfh or die "Unable to close $log_location: $!";
3478 if ($param{get_lock}) {
3479 unfilelock(exists $param{locks}?$param{locks}:());
3487 =head1 PRIVATE FUNCTIONS
3489 =head2 __handle_affected_packages
3491 __handle_affected_packages(affected_packages => {},
3499 sub __handle_affected_packages{
3500 my %param = validate_with(params => \@_,
3501 spec => {%common_options,
3502 data => {type => ARRAYREF|HASHREF
3507 for my $data (make_list($param{data})) {
3508 next unless exists $data->{package} and defined $data->{package};
3509 my @packages = split /\s*,\s*/,$data->{package};
3510 @{$param{affected_packages}}{@packages} = (1) x @packages;
3514 =head2 __handle_debug_transcript
3516 my ($debug,$transcript) = __handle_debug_transcript(%param);
3518 Returns a debug and transcript filehandle
3523 sub __handle_debug_transcript{
3524 my %param = validate_with(params => \@_,
3525 spec => {%common_options},
3528 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3529 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3530 return ($debug,$transcript);
3537 Produces a small bit of bug information to kick out to the transcript
3544 next unless defined $data and exists $data->{bug_num};
3545 $return .= "Bug #".($data->{bug_num}||'').
3546 ((defined $data->{done} and length $data->{done})?
3547 " {Done: $data->{done}}":''
3549 " [".($data->{package}||'(no package)'). "] ".
3550 ($data->{subject}||'(no subject)')."\n";
3556 =head2 __internal_request
3558 __internal_request()
3559 __internal_request($level)
3561 Returns true if the caller of the function calling __internal_request
3562 belongs to __PACKAGE__
3564 This allows us to be magical, and don't bother to print bug info if
3565 the second caller is from this package, amongst other things.
3567 An optional level is allowed, which increments the number of levels to
3568 check by the given value. [This is basically for use by internal
3569 functions like __begin_control which are always called by
3574 sub __internal_request{
3576 $l = 0 if not defined $l;
3577 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3583 sub __return_append_to_log_options{
3585 my $action = $param{action} if exists $param{action};
3586 if (not exists $param{requester}) {
3587 $param{requester} = $config{control_internal_requester};
3589 if (not exists $param{request_addr}) {
3590 $param{request_addr} = $config{control_internal_request_addr};
3592 if (not exists $param{message}) {
3593 my $date = rfc822_date();
3595 encode_headers(fill_in_template(template => 'mail/fake_control_message',
3596 variables => {request_addr => $param{request_addr},
3597 requester => $param{requester},
3603 if (not defined $action) {
3604 carp "Undefined action!";
3605 $action = "unknown action";
3607 return (action => $action,
3608 hash_slice(%param,keys %append_action_options),
3612 =head2 __begin_control
3614 my %info = __begin_control(%param,
3616 command=>'unarchive');
3617 my ($debug,$transcript) = @info{qw(debug transcript)};
3618 my @data = @{$info{data}};
3619 my @bugs = @{$info{bugs}};
3622 Starts the process of modifying a bug; handles all of the generic
3623 things that almost every control request needs
3625 Returns a hash containing
3629 =item new_locks -- number of new locks taken out by this call
3631 =item debug -- the debug file handle
3633 =item transcript -- the transcript file handle
3635 =item data -- an arrayref containing the data of the bugs
3636 corresponding to this request
3638 =item bugs -- an arrayref containing the bug numbers of the bugs
3639 corresponding to this request
3647 sub __begin_control {
3648 my %param = validate_with(params => \@_,
3649 spec => {bug => {type => SCALAR,
3652 archived => {type => BOOLEAN,
3655 command => {type => SCALAR,
3663 my ($debug,$transcript) = __handle_debug_transcript(@_);
3664 print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n";
3665 # print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n";
3666 $lockhash = $param{locks} if exists $param{locks};
3668 my $old_die = $SIG{__DIE__};
3669 $SIG{__DIE__} = *sig_die{CODE};
3671 ($new_locks, @data) =
3672 lock_read_all_merged_bugs(bug => $param{bug},
3673 $param{archived}?(location => 'archive'):(),
3674 exists $param{locks} ? (locks => $param{locks}):(),
3676 $locks += $new_locks;
3678 die "Unable to read any bugs successfully.";
3680 if (not $param{archived}) {
3681 for my $data (@data) {
3682 if ($data->{archived}) {
3683 die "Not altering archived bugs; see unarchive.";
3687 if (not check_limit(data => \@data,
3688 exists $param{limit}?(limit => $param{limit}):(),
3689 transcript => $transcript,
3691 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3694 __handle_affected_packages(%param,data => \@data);
3695 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3696 print {$debug} "$param{bug} read $locks locks\n";
3697 if (not @data or not defined $data[0]) {
3698 print {$transcript} "No bug found for $param{bug}\n";
3699 die "No bug found for $param{bug}";
3702 add_recipients(data => \@data,
3703 recipients => $param{recipients},
3704 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3706 (__internal_request()?(transcript => $transcript):()),
3709 print {$debug} "$param{bug} read done\n";
3710 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3711 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3712 return (data => \@data,
3714 old_die => $old_die,
3715 new_locks => $new_locks,
3717 transcript => $transcript,
3719 exists $param{locks}?(locks => $param{locks}):(),
3723 =head2 __end_control
3725 __end_control(%info);
3727 Handles tearing down from a control request
3733 if (exists $info{new_locks} and $info{new_locks} > 0) {
3734 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3735 for (1..$info{new_locks}) {
3736 unfilelock(exists $info{locks}?$info{locks}:());
3740 $SIG{__DIE__} = $info{old_die};
3741 if (exists $info{param}{affected_bugs}) {
3742 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3744 add_recipients(recipients => $info{param}{recipients},
3745 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3746 data => $info{data},
3747 debug => $info{debug},
3748 transcript => $info{transcript},
3750 __handle_affected_packages(%{$info{param}},data=>$info{data});
3756 check_limit(data => \@data, limit => $param{limit});
3759 Checks to make sure that bugs match any limits; each entry of @data
3760 much satisfy the limit.
3762 Returns true if there are no entries in data, or there are no keys in
3763 limit; returns false (0) if there are any entries which do not match.
3765 The limit hashref elements can contain an arrayref of scalars to
3766 match; regexes are also acccepted. At least one of the entries in each
3767 element needs to match the corresponding field in all data for the
3774 my %param = validate_with(params => \@_,
3775 spec => {data => {type => ARRAYREF|HASHREF,
3777 limit => {type => HASHREF|UNDEF,
3779 transcript => {type => SCALARREF|HANDLE,
3784 my @data = make_list($param{data});
3786 not defined $param{limit} or
3787 not keys %{$param{limit}}) {
3790 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3791 my $going_to_fail = 0;
3792 for my $data (@data) {
3793 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3794 status => dclone($data),
3796 for my $field (keys %{$param{limit}}) {
3797 next unless exists $param{limit}{$field};
3799 my @data_fields = make_list($data->{$field});
3800 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3801 if (not ref $limit) {
3802 for my $data_field (@data_fields) {
3803 if ($data_field eq $limit) {
3809 elsif (ref($limit) eq 'Regexp') {
3810 for my $data_field (@data_fields) {
3811 if ($data_field =~ $limit) {
3818 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3823 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3824 "' does not match at least one of ".
3825 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3829 return $going_to_fail?0:1;
3837 We override die to specially handle unlocking files in the cases where
3838 we are called via eval. [If we're not called via eval, it doesn't
3844 if ($^S) { # in eval
3846 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3853 # =head2 __message_body_template
3855 # message_body_template('mail/ack',{ref=>'foo'});
3857 # Creates a message body using a template
3861 sub __message_body_template{
3862 my ($template,$extra_var) = @_;
3864 my $hole_var = {'&bugurl' =>
3866 'http://'.$config{cgi_domain}.'/'.
3867 Debbugs::CGI::bug_links(bug => $_[0],
3873 my $body = fill_in_template(template => $template,
3874 variables => {config => \%config,
3877 hole_var => $hole_var,
3879 return fill_in_template(template => 'mail/message_body',
3880 variables => {config => \%config,
3884 hole_var => $hole_var,
3888 sub __all_undef_or_equal {
3890 return 1 if @values == 1 or @values == 0;
3891 my $not_def = grep {not defined $_} @values;
3892 if ($not_def == @values) {
3895 if ($not_def > 0 and $not_def != @values) {
3898 my $first_val = shift @values;
3899 for my $val (@values) {
3900 if ($first_val ne $val) {