1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # [Other people have contributed to this file; their copyrights should
8 # Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
10 package Debbugs::Control;
14 Debbugs::Control -- Routines for modifying the state of bugs
23 This module is an abstraction of a lot of functions which originally
24 were only present in service.in, but as time has gone on needed to be
25 called from elsewhere.
27 All of the public functions take the following options:
31 =item debug -- scalar reference to which debbuging information is
34 =item transcript -- scalar reference to which transcript information
37 =item affected_bugs -- hashref which is updated with bugs affected by
43 Functions which should (probably) append to the .log file take the
48 =item requester -- Email address of the individual who requested the change
50 =item request_addr -- Address to which the request was sent
52 =item request_nn -- Name of queue file which caused this request
54 =item request_msgid -- Message id of message which caused this request
56 =item location -- Optional location; currently ignored but may be
57 supported in the future for updating archived bugs upon archival
59 =item message -- The original message which caused the action to be taken
61 =item append_log -- Whether or not to append information to the log.
65 B<append_log> (for most functions) is a special option. When set to
66 false, no appending to the log is done at all. When it is not present,
67 the above information is faked, and appended to the log file. When it
68 is true, the above options must be present, and their values are used.
71 =head1 GENERAL FUNCTIONS
77 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
78 use base qw(Exporter);
82 $DEBUG = 0 unless defined $DEBUG;
85 %EXPORT_TAGS = (done => [qw(set_done)],
86 submitter => [qw(set_submitter)],
87 severity => [qw(set_severity)],
88 affects => [qw(affects)],
89 summary => [qw(summary)],
91 title => [qw(set_title)],
92 forward => [qw(set_forwarded)],
93 found => [qw(set_found set_fixed)],
94 fixed => [qw(set_found set_fixed)],
95 package => [qw(set_package)],
96 block => [qw(set_blocks)],
97 merge => [qw(set_merged)],
99 clone => [qw(clone_bug)],
100 archive => [qw(bug_archive bug_unarchive),
102 log => [qw(append_action_to_log),
106 Exporter::export_ok_tags(keys %EXPORT_TAGS);
107 $EXPORT_TAGS{all} = [@EXPORT_OK];
110 use Debbugs::Config qw(:config);
111 use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions :utf8);
112 use Debbugs::Status qw(bug_archiveable :read :hook writebug new_bug splitpackages split_status_fields get_bug_status);
113 use Debbugs::CGI qw(html_escape);
114 use Debbugs::Log qw(:misc :write);
115 use Debbugs::Recipients qw(:add);
116 use Debbugs::Packages qw(:versions :mapping);
118 use Data::Dumper qw();
119 use Params::Validate qw(validate_with :types);
120 use File::Path qw(mkpath);
121 use File::Copy qw(copy);
124 use Debbugs::Text qw(:templates);
126 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
127 use Debbugs::MIME qw(create_mime_message);
129 use Mail::RFC822::Address qw();
131 use POSIX qw(strftime);
133 use Storable qw(dclone nfreeze);
134 use List::Util qw(first max);
135 use Encode qw(encode_utf8);
139 # These are a set of options which are common to all of these functions
141 my %common_options = (debug => {type => SCALARREF|HANDLE,
144 transcript => {type => SCALARREF|HANDLE,
147 affected_bugs => {type => HASHREF,
150 affected_packages => {type => HASHREF,
153 recipients => {type => HASHREF,
156 limit => {type => HASHREF,
159 show_bug_info => {type => BOOLEAN,
162 request_subject => {type => SCALAR,
163 default => 'Unknown Subject',
165 request_msgid => {type => SCALAR,
168 request_nn => {type => SCALAR,
171 request_replyto => {type => SCALAR,
174 locks => {type => HASHREF,
180 my %append_action_options =
181 (action => {type => SCALAR,
184 requester => {type => SCALAR,
187 request_addr => {type => SCALAR,
190 location => {type => SCALAR,
193 message => {type => SCALAR|ARRAYREF,
196 append_log => {type => BOOLEAN,
198 depends => [qw(requester request_addr),
202 # locks is both an append_action option, and a common option;
203 # it's ok for it to be in both places.
204 locks => {type => HASHREF,
212 # this is just a generic stub for Debbugs::Control functions.
217 # set_foo(bug => $ref,
218 # transcript => $transcript,
219 # ($dl > 0 ? (debug => $transcript):()),
220 # requester => $header{from},
221 # request_addr => $controlrequestaddr,
223 # affected_packages => \%affected_packages,
224 # recipients => \%recipients,
230 # print {$transcript} "Failed to set foo $ref bar: $@";
238 # my %param = validate_with(params => \@_,
239 # spec => {bug => {type => SCALAR,
240 # regex => qr/^\d+$/,
242 # # specific options here
244 # %append_action_options,
248 # __begin_control(%param,
251 # my ($debug,$transcript) =
252 # @info{qw(debug transcript)};
253 # my @data = @{$info{data}};
254 # my @bugs = @{$info{bugs}};
257 # for my $data (@data) {
258 # append_action_to_log(bug => $data->{bug_num},
260 # __return_append_to_log_options(
265 # if not exists $param{append_log} or $param{append_log};
266 # writebug($data->{bug_num},$data);
267 # print {$transcript} "$action\n";
269 # __end_control(%info);
276 set_block(bug => $ref,
277 transcript => $transcript,
278 ($dl > 0 ? (debug => $transcript):()),
279 requester => $header{from},
280 request_addr => $controlrequestaddr,
282 affected_packages => \%affected_packages,
283 recipients => \%recipients,
289 print {$transcript} "Failed to set blockers of $ref: $@";
292 Alters the set of bugs that block this bug from being fixed
294 This requires altering both this bug (and those it's merged with) as
295 well as the bugs that block this bug from being fixed (and those that
300 =item block -- scalar or arrayref of blocking bugs to set, add or remove
302 =item add -- if true, add blocking bugs
304 =item remove -- if true, remove blocking bugs
311 my %param = validate_with(params => \@_,
312 spec => {bug => {type => SCALAR,
315 # specific options here
316 block => {type => SCALAR|ARRAYREF,
319 add => {type => BOOLEAN,
322 remove => {type => BOOLEAN,
326 %append_action_options,
329 if ($param{add} and $param{remove}) {
330 croak "It's nonsensical to add and remove the same blocking bugs";
332 if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
333 croak "Invalid blocking bug(s):".
334 join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
340 elsif ($param{remove}) {
345 __begin_control(%param,
348 my ($debug,$transcript) =
349 @info{qw(debug transcript)};
350 my @data = @{$info{data}};
351 my @bugs = @{$info{bugs}};
354 # The first bit of this code is ugly, and should be cleaned up.
355 # Its purpose is to populate %removed_blockers and %add_blockers
356 # with all of the bugs that should be added or removed as blockers
357 # of all of the bugs which are merged with $param{bug}
360 for my $blocker (make_list($param{block})) {
361 next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
362 my $data = read_bug(bug=>$blocker,
364 if (defined $data and not $data->{archive}) {
365 $data = split_status_fields($data);
366 $ok_blockers{$blocker} = 1;
368 push @merged_bugs, make_list($data->{mergedwith});
369 @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
372 $bad_blockers{$blocker} = 1;
376 # throw an error if we are setting the blockers and there is a bad
378 if (keys %bad_blockers and $mode eq 'set') {
379 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
380 keys %ok_blockers?'':" and no known blocking bug(s)";
382 # if there are no ok blockers and we are not setting the blockers,
384 if (not keys %ok_blockers and $mode ne 'set') {
385 print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
386 if (keys %bad_blockers) {
387 croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
389 __end_control(%info);
393 my @change_blockers = keys %ok_blockers;
395 my %removed_blockers;
398 my @blockers = map {split ' ', $_->{blockedby}} @data;
400 @blockers{@blockers} = (1) x @blockers;
402 # it is nonsensical for a bug to block itself (or a merged
403 # partner); We currently don't allow removal because we'd possibly
407 @bugs{@bugs} = (1) x @bugs;
408 for my $blocker (@change_blockers) {
409 if ($bugs{$blocker}) {
410 croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
413 @blockers = keys %blockers;
415 %removed_blockers = ();
416 for my $blocker (@change_blockers) {
417 next if exists $blockers{$blocker};
418 $blockers{$blocker} = 1;
419 $added_blockers{$blocker} = 1;
422 elsif ($param{remove}) {
423 %added_blockers = ();
424 for my $blocker (@change_blockers) {
425 next if exists $removed_blockers{$blocker};
426 delete $blockers{$blocker};
427 $removed_blockers{$blocker} = 1;
431 @removed_blockers{@blockers} = (1) x @blockers;
433 for my $blocker (@change_blockers) {
434 next if exists $blockers{$blocker};
435 $blockers{$blocker} = 1;
436 if (exists $removed_blockers{$blocker}) {
437 delete $removed_blockers{$blocker};
440 $added_blockers{$blocker} = 1;
444 my @new_blockers = keys %blockers;
445 for my $data (@data) {
446 my $old_data = dclone($data);
447 # remove blockers and/or add new ones as appropriate
448 if ($data->{blockedby} eq '') {
449 print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n";
451 print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n";
453 if ($data->{blocks} eq '') {
454 print {$transcript} "$data->{bug_num} was not blocking any bugs.\n";
456 print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n";
459 push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
460 push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers;
461 $action = ucfirst(join ('; ',@changed)) if @changed;
463 print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n";
466 $data->{blockedby} = join(' ',keys %blockers);
467 append_action_to_log(bug => $data->{bug_num},
469 old_data => $old_data,
472 __return_append_to_log_options(
477 if not exists $param{append_log} or $param{append_log};
478 writebug($data->{bug_num},$data);
479 print {$transcript} "$action\n";
481 # we do this bit below to avoid code duplication
483 $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
484 $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
486 for my $add_remove (keys %mungable_blocks) {
490 for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
491 next if $munge_blockers{$blocker};
492 my ($temp_locks, @blocking_data) =
493 lock_read_all_merged_bugs(bug => $blocker,
494 ($param{archived}?(location => 'archive'):()),
495 exists $param{locks}?(locks => $param{locks}):(),
497 $locks+= $temp_locks;
498 $new_locks+=$temp_locks;
499 if (not @blocking_data) {
500 for (1..$new_locks) {
501 unfilelock(exists $param{locks}?$param{locks}:());
504 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
506 for (map {$_->{bug_num}} @blocking_data) {
507 $munge_blockers{$_} = 1;
509 for my $data (@blocking_data) {
510 my $old_data = dclone($data);
512 my @blocks = split ' ', $data->{blocks};
513 @blocks{@blocks} = (1) x @blocks;
515 for my $bug (@bugs) {
516 if ($add_remove eq 'remove') {
517 next unless exists $blocks{$bug};
518 delete $blocks{$bug};
521 next if exists $blocks{$bug};
526 $data->{blocks} = join(' ',sort keys %blocks);
527 my $action = ($add_remove eq 'add'?'Added':'Removed').
528 " indication that bug $data->{bug_num} blocks ".
530 append_action_to_log(bug => $data->{bug_num},
532 old_data => $old_data,
535 __return_append_to_log_options(%param,
539 writebug($data->{bug_num},$data);
541 __handle_affected_packages(%param,data=>\@blocking_data);
542 add_recipients(recipients => $param{recipients},
543 actions_taken => {blocks => 1},
544 data => \@blocking_data,
546 transcript => $transcript,
549 for (1..$new_locks) {
550 unfilelock(exists $param{locks}?$param{locks}:());
555 __end_control(%info);
564 transcript => $transcript,
565 ($dl > 0 ? (debug => $transcript):()),
566 requester => $header{from},
567 request_addr => $controlrequestaddr,
569 affected_packages => \%affected_packages,
570 recipients => \%recipients,
577 print {$transcript} "Failed to set tag on $ref: $@";
581 Sets, adds, or removes the specified tags on a bug
585 =item tag -- scalar or arrayref of tags to set, add or remove
587 =item add -- if true, add tags
589 =item remove -- if true, remove tags
591 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
599 my %param = validate_with(params => \@_,
600 spec => {bug => {type => SCALAR,
603 # specific options here
604 tag => {type => SCALAR|ARRAYREF,
607 add => {type => BOOLEAN,
610 remove => {type => BOOLEAN,
613 warn_on_bad_tags => {type => BOOLEAN,
617 %append_action_options,
620 if ($param{add} and $param{remove}) {
621 croak "It's nonsensical to add and remove the same tags";
625 __begin_control(%param,
628 my ($debug,$transcript) =
629 @info{qw(debug transcript)};
630 my @data = @{$info{data}};
631 my @bugs = @{$info{bugs}};
632 my @tags = make_list($param{tag});
633 if (not @tags and ($param{remove} or $param{add})) {
634 if ($param{remove}) {
635 print {$transcript} "Requested to remove no tags; doing nothing.\n";
638 print {$transcript} "Requested to add no tags; doing nothing.\n";
640 __end_control(%info);
643 # first things first, make the versions fully qualified source
645 for my $data (@data) {
646 my $action = 'Did not alter tags';
648 my %tag_removed = ();
649 my %fixed_removed = ();
650 my @old_tags = split /\,?\s+/, $data->{keywords};
652 @tags{@old_tags} = (1) x @old_tags;
654 my $old_data = dclone($data);
655 if (not $param{add} and not $param{remove}) {
656 $tag_removed{$_} = 1 for @old_tags;
660 for my $tag (@tags) {
661 if (not $param{remove} and
662 not defined first {$_ eq $tag} @{$config{tags}}) {
663 push @bad_tags, $tag;
667 if (not exists $tags{$tag}) {
669 $tag_added{$tag} = 1;
672 elsif ($param{remove}) {
673 if (exists $tags{$tag}) {
675 $tag_removed{$tag} = 1;
679 if (exists $tag_removed{$tag}) {
680 delete $tag_removed{$tag};
683 $tag_added{$tag} = 1;
688 if (@bad_tags and $param{warn_on_bad_tags}) {
689 print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
690 print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
692 $data->{keywords} = join(' ',keys %tags);
695 push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
696 push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
697 $action = ucfirst(join ('; ',@changed)) if @changed;
699 print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n";
703 append_action_to_log(bug => $data->{bug_num},
706 old_data => $old_data,
708 __return_append_to_log_options(
713 if not exists $param{append_log} or $param{append_log};
714 writebug($data->{bug_num},$data);
715 print {$transcript} "$action\n";
717 __end_control(%info);
725 set_severity(bug => $ref,
726 transcript => $transcript,
727 ($dl > 0 ? (debug => $transcript):()),
728 requester => $header{from},
729 request_addr => $controlrequestaddr,
731 affected_packages => \%affected_packages,
732 recipients => \%recipients,
733 severity => 'normal',
738 print {$transcript} "Failed to set the severity of bug $ref: $@";
741 Sets the severity of a bug. If severity is not passed, is undefined,
742 or has zero length, sets the severity to the default severity.
747 my %param = validate_with(params => \@_,
748 spec => {bug => {type => SCALAR,
751 # specific options here
752 severity => {type => SCALAR|UNDEF,
753 default => $config{default_severity},
756 %append_action_options,
759 if (not defined $param{severity} or
760 not length $param{severity}
762 $param{severity} = $config{default_severity};
765 # check validity of new severity
766 if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
767 die "Severity '$param{severity}' is not a valid severity level";
770 __begin_control(%param,
771 command => 'severity'
773 my ($debug,$transcript) =
774 @info{qw(debug transcript)};
775 my @data = @{$info{data}};
776 my @bugs = @{$info{bugs}};
779 for my $data (@data) {
780 if (not defined $data->{severity}) {
781 $data->{severity} = $param{severity};
782 $action = "Severity set to '$param{severity}'";
785 if ($data->{severity} eq '') {
786 $data->{severity} = $config{default_severity};
788 if ($data->{severity} eq $param{severity}) {
789 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
792 $action = "Severity set to '$param{severity}' from '$data->{severity}'";
793 $data->{severity} = $param{severity};
795 append_action_to_log(bug => $data->{bug_num},
797 __return_append_to_log_options(
802 if not exists $param{append_log} or $param{append_log};
803 writebug($data->{bug_num},$data);
804 print {$transcript} "$action\n";
806 __end_control(%info);
813 set_done(bug => $ref,
814 transcript => $transcript,
815 ($dl > 0 ? (debug => $transcript):()),
816 requester => $header{from},
817 request_addr => $controlrequestaddr,
819 affected_packages => \%affected_packages,
820 recipients => \%recipients,
825 print {$transcript} "Failed to set foo $ref bar: $@";
833 my %param = validate_with(params => \@_,
834 spec => {bug => {type => SCALAR,
837 reopen => {type => BOOLEAN,
840 submitter => {type => SCALAR,
843 clear_fixed => {type => BOOLEAN,
846 notify_submitter => {type => BOOLEAN,
849 original_report => {type => SCALARREF,
852 done => {type => SCALAR|UNDEF,
856 %append_action_options,
860 if (exists $param{submitter} and
861 not Mail::RFC822::Address::valid($param{submitter})) {
862 die "New submitter address '$param{submitter}' is not a valid e-mail address";
864 if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address
865 $param{done} = $param{requester};
867 if (exists $param{done} and
868 (not defined $param{done} or
869 not length $param{done})) {
875 __begin_control(%param,
876 command => $param{reopen}?'reopen':'done',
878 my ($debug,$transcript) =
879 @info{qw(debug transcript)};
880 my @data = @{$info{data}};
881 my @bugs = @{$info{bugs}};
884 if ($param{reopen}) {
885 # avoid warning multiple times if there are fixed versions
887 for my $data (@data) {
888 if (not exists $data->{done} or
889 not defined $data->{done} or
890 not length $data->{done}) {
891 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
892 __end_control(%info);
895 if (@{$data->{fixed_versions}} and $warn_fixed) {
896 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
897 print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n";
901 $action = "Bug reopened";
902 for my $data (@data) {
903 my $old_data = dclone($data);
905 append_action_to_log(bug => $data->{bug_num},
908 old_data => $old_data,
910 __return_append_to_log_options(
915 if not exists $param{append_log} or $param{append_log};
916 writebug($data->{bug_num},$data);
918 print {$transcript} "$action\n";
919 __end_control(%info);
920 if (exists $param{submitter}) {
921 set_submitter(bug => $param{bug},
922 submitter => $param{submitter},
924 keys %common_options,
925 keys %append_action_options)
928 # clear the fixed revisions
929 if ($param{clear_fixed}) {
930 set_fixed(fixed => [],
934 keys %common_options,
935 keys %append_action_options),
940 my %submitter_notified;
941 my $requester_notified = 0;
942 my $orig_report_set = 0;
943 for my $data (@data) {
944 if (exists $data->{done} and
945 defined $data->{done} and
946 length $data->{done}) {
947 print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
948 __end_control(%info);
952 for my $data (@data) {
953 my $old_data = dclone($data);
954 my $hash = get_hashname($data->{bug_num});
955 my $report_fh = IO::File->new("$config{spool_dir}/db-h/$hash/$data->{bug_num}.report",'r') or
956 die "Unable to open original report $config{spool_dir}/db-h/$hash/$data->{bug_num}.report for reading: $!";
960 $orig_report= <$report_fh>;
963 if (not $orig_report_set and defined $orig_report and
964 length $orig_report and
965 exists $param{original_report}){
966 ${$param{original_report}} = $orig_report;
967 $orig_report_set = 1;
970 $action = "Marked $config{bug} as done";
972 # set done to the requester
973 $data->{done} = exists $param{done}?$param{done}:$param{requester};
974 append_action_to_log(bug => $data->{bug_num},
977 old_data => $old_data,
979 __return_append_to_log_options(
984 if not exists $param{append_log} or $param{append_log};
985 writebug($data->{bug_num},$data);
986 print {$transcript} "$action\n";
987 # get the original report
988 if ($param{notify_submitter}) {
989 my $submitter_message;
990 if(not exists $submitter_notified{$data->{originator}}) {
992 create_mime_message([default_headers(queue_file => $param{request_nn},
994 msgid => $param{request_msgid},
995 msgtype => 'notifdone',
996 pr_msg => 'they-closed',
998 [To => $data->{submitter},
999 Subject => "$config{ubug}#$data->{bug_num} ".
1000 "closed by $param{requester} ".(defined $param{request_subject}?"($param{request_subject})":""),
1004 __message_body_template('mail/process_your_bug_done',
1006 replyto => (exists $param{request_replyto} ?
1007 $param{request_replyto} :
1008 $param{requester} || 'Unknown'),
1009 markedby => $param{requester},
1010 subject => $param{request_subject},
1011 messageid => $param{request_msgid},
1014 [join('',make_list($param{message})),$orig_report]
1016 send_mail_message(message => $submitter_message,
1017 recipients => $old_data->{submitter},
1019 $submitter_notified{$data->{originator}} = $submitter_message;
1022 $submitter_message = $submitter_notified{$data->{originator}};
1024 append_action_to_log(bug => $data->{bug_num},
1025 action => "Notification sent",
1027 request_addr => $data->{originator},
1028 desc => "$config{bug} acknowledged by developer.",
1029 recips => [$data->{originator}],
1030 message => $submitter_message,
1035 __end_control(%info);
1036 if (exists $param{fixed}) {
1037 set_fixed(fixed => $param{fixed},
1041 keys %common_options,
1042 keys %append_action_options
1050 =head2 set_submitter
1053 set_submitter(bug => $ref,
1054 transcript => $transcript,
1055 ($dl > 0 ? (debug => $transcript):()),
1056 requester => $header{from},
1057 request_addr => $controlrequestaddr,
1059 affected_packages => \%affected_packages,
1060 recipients => \%recipients,
1061 submitter => $new_submitter,
1062 notify_submitter => 1,
1067 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1070 Sets the submitter of a bug. If notify_submitter is true (the
1071 default), notifies the old submitter of a bug on changes
1076 my %param = validate_with(params => \@_,
1077 spec => {bug => {type => SCALAR,
1080 # specific options here
1081 submitter => {type => SCALAR,
1083 notify_submitter => {type => BOOLEAN,
1087 %append_action_options,
1090 if (not Mail::RFC822::Address::valid($param{submitter})) {
1091 die "New submitter address $param{submitter} is not a valid e-mail address";
1094 __begin_control(%param,
1095 command => 'submitter'
1097 my ($debug,$transcript) =
1098 @info{qw(debug transcript)};
1099 my @data = @{$info{data}};
1100 my @bugs = @{$info{bugs}};
1102 # here we only concern ourselves with the first of the merged bugs
1103 for my $data ($data[0]) {
1104 my $notify_old_submitter = 0;
1105 my $old_data = dclone($data);
1106 print {$debug} "Going to change bug submitter\n";
1107 if (((not defined $param{submitter} or not length $param{submitter}) and
1108 (not defined $data->{originator} or not length $data->{originator})) or
1109 (defined $param{submitter} and defined $data->{originator} and
1110 $param{submitter} eq $data->{originator})) {
1111 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n";
1115 if (defined $data->{originator} and length($data->{originator})) {
1116 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
1117 $notify_old_submitter = 1;
1120 $action= "Set $config{bug} submitter to '$param{submitter}'.";
1122 $data->{originator} = $param{submitter};
1124 append_action_to_log(bug => $data->{bug_num},
1125 command => 'submitter',
1127 old_data => $old_data,
1129 __return_append_to_log_options(
1134 if not exists $param{append_log} or $param{append_log};
1135 writebug($data->{bug_num},$data);
1136 print {$transcript} "$action\n";
1137 # notify old submitter
1138 if ($notify_old_submitter and $param{notify_submitter}) {
1139 send_mail_message(message =>
1140 create_mime_message([default_headers(queue_file => $param{request_nn},
1142 msgid => $param{request_msgid},
1144 pr_msg => 'submitter-changed',
1146 [To => $old_data->{submitter},
1147 Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
1151 __message_body_template('mail/submitter_changed',
1152 {old_data => $old_data,
1154 replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
1158 recipients => $old_data->{submitter},
1162 __end_control(%info);
1167 =head2 set_forwarded
1170 set_forwarded(bug => $ref,
1171 transcript => $transcript,
1172 ($dl > 0 ? (debug => $transcript):()),
1173 requester => $header{from},
1174 request_addr => $controlrequestaddr,
1176 affected_packages => \%affected_packages,
1177 recipients => \%recipients,
1178 forwarded => $forward_to,
1183 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1186 Sets the location to which a bug is forwarded. Given an undef
1187 forwarded, unsets forwarded.
1193 my %param = validate_with(params => \@_,
1194 spec => {bug => {type => SCALAR,
1197 # specific options here
1198 forwarded => {type => SCALAR|UNDEF,
1201 %append_action_options,
1204 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1205 die "Non-printable characters are not allowed in the forwarded field";
1207 $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
1209 __begin_control(%param,
1210 command => 'forwarded'
1212 my ($debug,$transcript) =
1213 @info{qw(debug transcript)};
1214 my @data = @{$info{data}};
1215 my @bugs = @{$info{bugs}};
1217 for my $data (@data) {
1218 my $old_data = dclone($data);
1219 print {$debug} "Going to change bug forwarded\n";
1220 if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
1221 (not defined $param{forwarded} and
1222 defined $data->{forwarded} and not length $data->{forwarded})) {
1223 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n";
1227 if (not defined $param{forwarded}) {
1228 $action= "Unset $config{bug} forwarded-to-address";
1230 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1231 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1234 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1236 $data->{forwarded} = $param{forwarded};
1238 append_action_to_log(bug => $data->{bug_num},
1239 command => 'forwarded',
1241 old_data => $old_data,
1243 __return_append_to_log_options(
1248 if not exists $param{append_log} or $param{append_log};
1249 writebug($data->{bug_num},$data);
1250 print {$transcript} "$action\n";
1252 __end_control(%info);
1261 set_title(bug => $ref,
1262 transcript => $transcript,
1263 ($dl > 0 ? (debug => $transcript):()),
1264 requester => $header{from},
1265 request_addr => $controlrequestaddr,
1267 affected_packages => \%affected_packages,
1268 recipients => \%recipients,
1269 title => $new_title,
1274 print {$transcript} "Failed to set the title of $ref: $@";
1277 Sets the title of a specific bug
1283 my %param = validate_with(params => \@_,
1284 spec => {bug => {type => SCALAR,
1287 # specific options here
1288 title => {type => SCALAR,
1291 %append_action_options,
1294 if ($param{title} =~ /[^[:print:]]/) {
1295 die "Non-printable characters are not allowed in bug titles";
1298 my %info = __begin_control(%param,
1301 my ($debug,$transcript) =
1302 @info{qw(debug transcript)};
1303 my @data = @{$info{data}};
1304 my @bugs = @{$info{bugs}};
1306 for my $data (@data) {
1307 my $old_data = dclone($data);
1308 print {$debug} "Going to change bug title\n";
1309 if (defined $data->{subject} and length($data->{subject}) and
1310 $data->{subject} eq $param{title}) {
1311 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n";
1315 if (defined $data->{subject} and length($data->{subject})) {
1316 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1318 $action= "Set $config{bug} title to '$param{title}'.";
1320 $data->{subject} = $param{title};
1322 append_action_to_log(bug => $data->{bug_num},
1325 old_data => $old_data,
1327 __return_append_to_log_options(
1332 if not exists $param{append_log} or $param{append_log};
1333 writebug($data->{bug_num},$data);
1334 print {$transcript} "$action\n";
1336 __end_control(%info);
1343 set_package(bug => $ref,
1344 transcript => $transcript,
1345 ($dl > 0 ? (debug => $transcript):()),
1346 requester => $header{from},
1347 request_addr => $controlrequestaddr,
1349 affected_packages => \%affected_packages,
1350 recipients => \%recipients,
1351 package => $new_package,
1357 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1360 Indicates that a bug is in a particular package. If is_source is true,
1361 indicates that the package is a source package. [Internally, this
1362 causes src: to be prepended to the package name.]
1364 The default for is_source is 0. As a special case, if the package
1365 starts with 'src:', it is assumed to be a source package and is_source
1368 The package option must match the package_name_re regex.
1373 my %param = validate_with(params => \@_,
1374 spec => {bug => {type => SCALAR,
1377 # specific options here
1378 package => {type => SCALAR|ARRAYREF,
1380 is_source => {type => BOOLEAN,
1384 %append_action_options,
1387 my @new_packages = map {splitpackages($_)} make_list($param{package});
1388 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1389 croak "Invalid package name '".
1390 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1393 my %info = __begin_control(%param,
1394 command => 'package',
1396 my ($debug,$transcript) =
1397 @info{qw(debug transcript)};
1398 my @data = @{$info{data}};
1399 my @bugs = @{$info{bugs}};
1400 # clean up the new package
1404 ($temp =~ s/^src:// or
1405 $param{is_source}) ? 'src:'.$temp:$temp;
1409 my $package_reassigned = 0;
1410 for my $data (@data) {
1411 my $old_data = dclone($data);
1412 print {$debug} "Going to change assigned package\n";
1413 if (defined $data->{package} and length($data->{package}) and
1414 $data->{package} eq $new_package) {
1415 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n";
1419 if (defined $data->{package} and length($data->{package})) {
1420 $package_reassigned = 1;
1421 $action= "$config{bug} reassigned from package '$data->{package}'".
1422 " to '$new_package'.";
1424 $action= "$config{bug} assigned to package '$new_package'.";
1426 $data->{package} = $new_package;
1428 append_action_to_log(bug => $data->{bug_num},
1429 command => 'package',
1431 old_data => $old_data,
1433 __return_append_to_log_options(
1438 if not exists $param{append_log} or $param{append_log};
1439 writebug($data->{bug_num},$data);
1440 print {$transcript} "$action\n";
1442 __end_control(%info);
1443 # Only clear the fixed/found versions if the package has been
1445 if ($package_reassigned) {
1446 my @params_for_found_fixed =
1447 map {exists $param{$_}?($_,$param{$_}):()}
1449 keys %common_options,
1450 keys %append_action_options,
1452 set_found(found => [],
1453 @params_for_found_fixed,
1455 set_fixed(fixed => [],
1456 @params_for_found_fixed,
1464 set_found(bug => $ref,
1465 transcript => $transcript,
1466 ($dl > 0 ? (debug => $transcript):()),
1467 requester => $header{from},
1468 request_addr => $controlrequestaddr,
1470 affected_packages => \%affected_packages,
1471 recipients => \%recipients,
1478 print {$transcript} "Failed to set found on $ref: $@";
1482 Sets, adds, or removes the specified found versions of a package
1484 If the version list is empty, and the bug is currently not "done",
1485 causes the done field to be cleared.
1487 If any of the versions added to found are greater than any version in
1488 which the bug is fixed (or when the bug is found and there are no
1489 fixed versions) the done field is cleared.
1494 my %param = validate_with(params => \@_,
1495 spec => {bug => {type => SCALAR,
1498 # specific options here
1499 found => {type => SCALAR|ARRAYREF,
1502 add => {type => BOOLEAN,
1505 remove => {type => BOOLEAN,
1509 %append_action_options,
1512 if ($param{add} and $param{remove}) {
1513 croak "It's nonsensical to add and remove the same versions";
1517 __begin_control(%param,
1520 my ($debug,$transcript) =
1521 @info{qw(debug transcript)};
1522 my @data = @{$info{data}};
1523 my @bugs = @{$info{bugs}};
1525 for my $version (make_list($param{found})) {
1526 next unless defined $version;
1527 $versions{$version} =
1528 [make_source_versions(package => [splitpackages($data[0]{package})],
1529 warnings => $transcript,
1532 versions => $version,
1535 # This is really ugly, but it's what we have to do
1536 if (not @{$versions{$version}}) {
1537 print {$transcript} "Unable to make a source version for version '$version'\n";
1540 if (not keys %versions and ($param{remove} or $param{add})) {
1541 if ($param{remove}) {
1542 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1545 print {$transcript} "Requested to add no versions; doing nothing.\n";
1547 __end_control(%info);
1550 # first things first, make the versions fully qualified source
1552 for my $data (@data) {
1553 # The 'done' field gets a bit weird with version tracking,
1554 # because a bug may be closed by multiple people in different
1555 # branches. Until we have something more flexible, we set it
1556 # every time a bug is fixed, and clear it when a bug is found
1557 # in a version greater than any version in which the bug is
1558 # fixed or when a bug is found and there is no fixed version
1559 my $action = 'Did not alter found versions';
1560 my %found_added = ();
1561 my %found_removed = ();
1562 my %fixed_removed = ();
1564 my $old_data = dclone($data);
1565 if (not $param{add} and not $param{remove}) {
1566 $found_removed{$_} = 1 for @{$data->{found_versions}};
1567 $data->{found_versions} = [];
1570 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1572 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1573 for my $version (keys %versions) {
1575 my @svers = @{$versions{$version}};
1580 if (exists $found_versions{$version}) {
1581 delete $found_versions{$version};
1582 $found_removed{$version} = 1;
1585 for my $sver (@svers) {
1586 if (not exists $found_versions{$sver}) {
1587 $found_versions{$sver} = 1;
1588 $found_added{$sver} = 1;
1590 # if the found we are adding matches any fixed
1591 # versions, remove them
1592 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1593 delete $fixed_versions{$_} for @temp;
1594 $fixed_removed{$_} = 1 for @temp;
1597 # We only care about reopening the bug if the bug is
1599 if (defined $data->{done} and length $data->{done}) {
1600 my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
1602 # determine if we need to reopen
1603 my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
1604 keys %fixed_versions);
1605 if (not @fixed_order or
1606 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1612 elsif ($param{remove}) {
1613 # in the case of removal, we only concern ourself with
1614 # the version passed, not the source version it maps
1616 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1617 delete $found_versions{$_} for @temp;
1618 $found_removed{$_} = 1 for @temp;
1621 # set the keys to exactly these values
1622 my @svers = @{$versions{$version}};
1626 for my $sver (@svers) {
1627 if (not exists $found_versions{$sver}) {
1628 $found_versions{$sver} = 1;
1629 if (exists $found_removed{$sver}) {
1630 delete $found_removed{$sver};
1633 $found_added{$sver} = 1;
1640 $data->{found_versions} = [keys %found_versions];
1641 $data->{fixed_versions} = [keys %fixed_versions];
1644 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1645 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1646 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1647 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1648 $action = ucfirst(join ('; ',@changed)) if @changed;
1650 $action .= " and reopened"
1652 if (not $reopened and not @changed) {
1653 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n";
1657 append_action_to_log(bug => $data->{bug_num},
1660 old_data => $old_data,
1662 __return_append_to_log_options(
1667 if not exists $param{append_log} or $param{append_log};
1668 writebug($data->{bug_num},$data);
1669 print {$transcript} "$action\n";
1671 __end_control(%info);
1677 set_fixed(bug => $ref,
1678 transcript => $transcript,
1679 ($dl > 0 ? (debug => $transcript):()),
1680 requester => $header{from},
1681 request_addr => $controlrequestaddr,
1683 affected_packages => \%affected_packages,
1684 recipients => \%recipients,
1692 print {$transcript} "Failed to set fixed on $ref: $@";
1696 Sets, adds, or removes the specified fixed versions of a package
1698 If the fixed versions are empty (or end up being empty after this
1699 call) or the greatest fixed version is less than the greatest found
1700 version and the reopen option is true, the bug is reopened.
1702 This function is also called by the reopen function, which causes all
1703 of the fixed versions to be cleared.
1708 my %param = validate_with(params => \@_,
1709 spec => {bug => {type => SCALAR,
1712 # specific options here
1713 fixed => {type => SCALAR|ARRAYREF,
1716 add => {type => BOOLEAN,
1719 remove => {type => BOOLEAN,
1722 reopen => {type => BOOLEAN,
1726 %append_action_options,
1729 if ($param{add} and $param{remove}) {
1730 croak "It's nonsensical to add and remove the same versions";
1733 __begin_control(%param,
1736 my ($debug,$transcript) =
1737 @info{qw(debug transcript)};
1738 my @data = @{$info{data}};
1739 my @bugs = @{$info{bugs}};
1741 for my $version (make_list($param{fixed})) {
1742 next unless defined $version;
1743 $versions{$version} =
1744 [make_source_versions(package => [splitpackages($data[0]{package})],
1745 warnings => $transcript,
1748 versions => $version,
1751 # This is really ugly, but it's what we have to do
1752 if (not @{$versions{$version}}) {
1753 print {$transcript} "Unable to make a source version for version '$version'\n";
1756 if (not keys %versions and ($param{remove} or $param{add})) {
1757 if ($param{remove}) {
1758 print {$transcript} "Requested to remove no versions; doing nothing.\n";
1761 print {$transcript} "Requested to add no versions; doing nothing.\n";
1763 __end_control(%info);
1766 # first things first, make the versions fully qualified source
1768 for my $data (@data) {
1769 my $old_data = dclone($data);
1770 # The 'done' field gets a bit weird with version tracking,
1771 # because a bug may be closed by multiple people in different
1772 # branches. Until we have something more flexible, we set it
1773 # every time a bug is fixed, and clear it when a bug is found
1774 # in a version greater than any version in which the bug is
1775 # fixed or when a bug is found and there is no fixed version
1776 my $action = 'Did not alter fixed versions';
1777 my %found_added = ();
1778 my %found_removed = ();
1779 my %fixed_added = ();
1780 my %fixed_removed = ();
1782 if (not $param{add} and not $param{remove}) {
1783 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1784 $data->{fixed_versions} = [];
1787 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1789 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1790 for my $version (keys %versions) {
1792 my @svers = @{$versions{$version}};
1797 if (exists $fixed_versions{$version}) {
1798 $fixed_removed{$version} = 1;
1799 delete $fixed_versions{$version};
1802 for my $sver (@svers) {
1803 if (not exists $fixed_versions{$sver}) {
1804 $fixed_versions{$sver} = 1;
1805 $fixed_added{$sver} = 1;
1809 elsif ($param{remove}) {
1810 # in the case of removal, we only concern ourself with
1811 # the version passed, not the source version it maps
1813 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1814 delete $fixed_versions{$_} for @temp;
1815 $fixed_removed{$_} = 1 for @temp;
1818 # set the keys to exactly these values
1819 my @svers = @{$versions{$version}};
1823 for my $sver (@svers) {
1824 if (not exists $fixed_versions{$sver}) {
1825 $fixed_versions{$sver} = 1;
1826 if (exists $fixed_removed{$sver}) {
1827 delete $fixed_removed{$sver};
1830 $fixed_added{$sver} = 1;
1837 $data->{found_versions} = [keys %found_versions];
1838 $data->{fixed_versions} = [keys %fixed_versions];
1840 # If we're supposed to consider reopening, reopen if the
1841 # fixed versions are empty or the greatest found version
1842 # is greater than the greatest fixed version
1843 if ($param{reopen} and defined $data->{done}
1844 and length $data->{done}) {
1845 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1846 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1847 # determine if we need to reopen
1848 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1849 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1850 if (not @fixed_order or
1851 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1858 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1859 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1860 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1861 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1862 $action = ucfirst(join ('; ',@changed)) if @changed;
1864 $action .= " and reopened"
1866 if (not $reopened and not @changed) {
1867 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n";
1871 append_action_to_log(bug => $data->{bug_num},
1874 old_data => $old_data,
1876 __return_append_to_log_options(
1881 if not exists $param{append_log} or $param{append_log};
1882 writebug($data->{bug_num},$data);
1883 print {$transcript} "$action\n";
1885 __end_control(%info);
1892 set_merged(bug => $ref,
1893 transcript => $transcript,
1894 ($dl > 0 ? (debug => $transcript):()),
1895 requester => $header{from},
1896 request_addr => $controlrequestaddr,
1898 affected_packages => \%affected_packages,
1899 recipients => \%recipients,
1900 merge_with => 12345,
1903 allow_reassign => 1,
1904 reassign_same_source_only => 1,
1909 print {$transcript} "Failed to set merged on $ref: $@";
1913 Sets, adds, or removes the specified merged bugs of a bug
1915 By default, requires
1920 my %param = validate_with(params => \@_,
1921 spec => {bug => {type => SCALAR,
1924 # specific options here
1925 merge_with => {type => ARRAYREF|SCALAR,
1928 remove => {type => BOOLEAN,
1931 force => {type => BOOLEAN,
1934 masterbug => {type => BOOLEAN,
1937 allow_reassign => {type => BOOLEAN,
1940 reassign_different_sources => {type => BOOLEAN,
1944 %append_action_options,
1947 my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1949 @merging{@merging} = (1) x @merging;
1950 if (grep {$_ !~ /^\d+$/} @merging) {
1951 croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1953 $param{locks} = {} if not exists $param{locks};
1955 __begin_control(%param,
1958 my ($debug,$transcript) =
1959 @info{qw(debug transcript)};
1960 if (not @merging and exists $param{merge_with}) {
1961 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1962 __end_control(%info);
1965 my @data = @{$info{data}};
1966 my @bugs = @{$info{bugs}};
1969 for my $data (@data) {
1970 $data{$data->{bug_num}} = $data;
1971 my @merged_bugs = split / /, $data->{mergedwith};
1972 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1976 if (not exists $param{merge_with}) {
1977 my $ok_to_unmerge = 1;
1978 delete $merged_bugs{$param{bug}};
1979 if (not keys %merged_bugs) {
1980 print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1981 __end_control(%info);
1984 my $action = "Disconnected #$param{bug} from all other report(s).";
1985 for my $data (@data) {
1986 my $old_data = dclone($data);
1987 if ($data->{bug_num} == $param{bug}) {
1988 $data->{mergedwith} = '';
1991 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
1994 append_action_to_log(bug => $data->{bug_num},
1997 old_data => $old_data,
1999 __return_append_to_log_options(%param,
2003 if not exists $param{append_log} or $param{append_log};
2004 writebug($data->{bug_num},$data);
2006 print {$transcript} "$action\n";
2007 __end_control(%info);
2010 # lock and load all of the bugs we need
2011 my @bugs_to_load = keys %merging;
2014 my ($data,$n_locks) =
2015 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2017 locks => $param{locks},
2020 $new_locks += $n_locks;
2022 @data = values %data;
2023 if (not __check_limit(data => [@data],
2024 exists $param{limit}?(limit => $param{limit}):(),
2025 transcript => $transcript,
2027 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2029 for my $data (@data) {
2030 $data{$data->{bug_num}} = $data;
2031 $merged_bugs{$data->{bug_num}} = 1;
2032 my @merged_bugs = split / /, $data->{mergedwith};
2033 @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2034 if (exists $param{affected_bugs}) {
2035 $param{affected_bugs}{$data->{bug_num}} = 1;
2038 __handle_affected_packages(%param,data => [@data]);
2039 my %bug_info_shown; # which bugs have had information shown
2040 $bug_info_shown{$param{bug}} = 1;
2041 add_recipients(data => [@data],
2042 recipients => $param{recipients},
2043 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2045 (__internal_request()?(transcript => $transcript):()),
2048 # Figure out what the ideal state is for the bug,
2049 my ($merge_status,$bugs_to_merge) =
2050 __calculate_merge_status(\@data,\%data,$param{bug});
2051 # find out if we actually have any bugs to merge
2052 if (not $bugs_to_merge) {
2053 print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2054 for (1..$new_locks) {
2055 unfilelock($param{locks});
2058 __end_control(%info);
2061 # see what changes need to be made to merge the bugs
2062 # check to make sure that the set of changes we need to make is allowed
2063 my ($disallowed_changes,$changes) =
2064 __calculate_merge_changes(\@data,$merge_status,\%param);
2065 # at this point, stop if there are disallowed changes, otherwise
2066 # make the allowed changes, and then reread the bugs in question
2067 # to get the new data, then recaculate the merges; repeat
2068 # reloading and recalculating until we try too many times or there
2069 # are no changes to make.
2072 # we will allow at most 4 times through this; more than 1
2073 # shouldn't really happen.
2075 while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2076 if ($attempts > 1) {
2077 print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2079 if (@{$disallowed_changes}) {
2080 # figure out the problems
2081 print {$transcript} "Unable to merge bugs because:\n";
2082 for my $change (@{$disallowed_changes}) {
2083 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2085 if ($attempts > 0) {
2086 croak "Some bugs were altered while attempting to merge";
2089 croak "Did not alter merged bugs";
2092 my @bugs_to_change = keys %{$changes};
2093 for my $change_bug (@bugs_to_change) {
2094 next unless exists $changes->{$change_bug};
2095 $bug_changed{$change_bug}++;
2096 print {$transcript} __bug_info($data{$change_bug}) if
2097 $param{show_bug_info} and not __internal_request(1);
2098 $bug_info_shown{$change_bug} = 1;
2099 __allow_relocking($param{locks},[keys %data]);
2100 for my $change (@{$changes->{$change_bug}}) {
2101 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2102 my %target_blockedby;
2103 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2104 my %unhandled_targets = %target_blockedby;
2105 my @blocks_to_remove;
2106 for my $key (split / /,$change->{orig_value}) {
2107 delete $unhandled_targets{$key};
2108 next if exists $target_blockedby{$key};
2109 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2110 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2113 keys %common_options,
2114 keys %append_action_options),
2117 for my $key (keys %unhandled_targets) {
2118 set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
2119 block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2122 keys %common_options,
2123 keys %append_action_options),
2128 $change->{function}->(bug => $change->{bug},
2129 $change->{key}, $change->{func_value},
2130 exists $change->{options}?@{$change->{options}}:(),
2132 keys %common_options,
2133 keys %append_action_options),
2137 __disallow_relocking($param{locks});
2138 my ($data,$n_locks) =
2139 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2141 locks => $param{locks},
2145 $new_locks += $n_locks;
2148 @data = values %data;
2149 ($merge_status,$bugs_to_merge) =
2150 __calculate_merge_status(\@data,\%data,$param{bug},$merge_status);
2151 ($disallowed_changes,$changes) =
2152 __calculate_merge_changes(\@data,$merge_status,\%param);
2153 $attempts = max(values %bug_changed);
2156 if ($param{show_bug_info} and not __internal_request(1)) {
2157 for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2158 next if $bug_info_shown{$data->{bug_num}};
2159 print {$transcript} __bug_info($data);
2162 if (keys %{$changes} or @{$disallowed_changes}) {
2163 print {$transcript} "After four attempts, the following changes were unable to be made:\n";
2164 for (1..$new_locks) {
2165 unfilelock($param{locks});
2168 __end_control(%info);
2169 for my $change (values %{$changes}, @{$disallowed_changes}) {
2170 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2172 die "Unable to modify bugs so they could be merged";
2176 # finally, we can merge the bugs
2177 my $action = "Merged ".join(' ',sort keys %merged_bugs);
2178 for my $data (@data) {
2179 my $old_data = dclone($data);
2180 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2182 append_action_to_log(bug => $data->{bug_num},
2185 old_data => $old_data,
2187 __return_append_to_log_options(%param,
2191 if not exists $param{append_log} or $param{append_log};
2192 writebug($data->{bug_num},$data);
2194 print {$transcript} "$action\n";
2195 # unlock the extra locks that we got earlier
2196 for (1..$new_locks) {
2197 unfilelock($param{locks});
2200 __end_control(%info);
2203 sub __allow_relocking{
2204 my ($locks,$bugs) = @_;
2206 my @locks = (@{$bugs},'merge');
2207 for my $lock (@locks) {
2208 my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}};
2209 next unless @lockfiles;
2210 $locks->{relockable}{$lockfiles[0]} = 0;
2214 sub __disallow_relocking{
2216 delete $locks->{relockable};
2219 sub __lock_and_load_merged_bugs{
2221 validate_with(params => \@_,
2223 {bugs_to_load => {type => ARRAYREF,
2224 default => sub {[]},
2226 data => {type => HASHREF|ARRAYREF,
2228 locks => {type => HASHREF,
2229 default => sub {{};},
2231 reload_all => {type => BOOLEAN,
2234 debug => {type => HANDLE,
2240 if (ref($param{data}) eq 'ARRAY') {
2241 for my $data (@{$param{data}}) {
2242 $data{$data->{bug_num}} = dclone($data);
2246 %data = %{dclone($param{data})};
2248 my @bugs_to_load = @{$param{bugs_to_load}};
2249 if ($param{reload_all}) {
2250 push @bugs_to_load, keys %data;
2253 @temp{@bugs_to_load} = (1) x @bugs_to_load;
2254 @bugs_to_load = keys %temp;
2255 my %loaded_this_time;
2257 while ($bug_to_load = shift @bugs_to_load) {
2258 if (not $param{reload_all}) {
2259 next if exists $data{$bug_to_load};
2262 next if $loaded_this_time{$bug_to_load};
2265 if ($param{reload_all}) {
2266 if (exists $data{$bug_to_load}) {
2271 read_bug(bug => $bug_to_load,
2273 locks => $param{locks},
2275 die "Unable to load bug $bug_to_load";
2276 print {$param{debug}} "read bug $bug_to_load\n";
2277 $data{$data->{bug_num}} = $data;
2278 $new_locks += $lock_bug;
2279 $loaded_this_time{$data->{bug_num}} = 1;
2281 grep {not exists $data{$_}}
2282 split / /,$data->{mergedwith};
2284 return (\%data,$new_locks);
2288 sub __calculate_merge_status{
2289 my ($data_a,$data_h,$master_bug,$merge_status) = @_;
2290 my %merge_status = %{$merge_status // {}};
2292 my $bugs_to_merge = 0;
2293 for my $data (@{$data_a}) {
2294 # check to see if this bug is unmerged in the set
2295 if (not length $data->{mergedwith} or
2296 grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2297 $merged_bugs{$data->{bug_num}} = 1;
2300 # the master_bug is the bug that every other bug is made to
2301 # look like. However, if merge is set, tags, fixed and found
2303 if ($data->{bug_num} == $master_bug) {
2304 for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2305 $merge_status{$_} = $data->{$_}
2308 if (defined $merge_status) {
2309 next unless $data->{bug_num} == $master_bug;
2311 $merge_status{tag} = {} if not exists $merge_status{tag};
2312 for my $tag (split /\s+/, $data->{keywords}) {
2313 $merge_status{tag}{$tag} = 1;
2315 $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2316 for (qw(fixed found)) {
2317 @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2320 return (\%merge_status,$bugs_to_merge);
2325 sub __calculate_merge_changes{
2326 my ($datas,$merge_status,$param) = @_;
2328 my @disallowed_changes;
2329 for my $data (@{$datas}) {
2330 # things that can be forced
2332 # * func is the function to set the new value
2334 # * key is the key of the function to set the value,
2336 # * modify_value is a function which is called to modify the new
2337 # value so that the function will accept it
2339 # * options is an ARRAYREF of options to pass to the function
2341 # * allowed is a BOOLEAN which controls whether this setting
2342 # is allowed to be different by default.
2343 my %force_functions =
2344 (forwarded => {func => \&set_forwarded,
2348 severity => {func => \&set_severity,
2352 blocks => {func => \&set_blocks,
2353 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2357 blockedby => {func => \&set_blocks,
2358 modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2362 done => {func => \&set_done,
2366 owner => {func => \&owner,
2370 summary => {func => \&summary,
2374 affects => {func => \&affects,
2378 package => {func => \&set_package,
2382 keywords => {func => \&set_tag,
2384 modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2387 fixed_versions => {func => \&set_fixed,
2389 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2392 found_versions => {func => \&set_found,
2394 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2398 for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2399 # if the ideal bug already has the field set properly, we
2401 if ($field eq 'keywords'){
2402 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2403 join(' ',sort keys %{$merge_status->{tag}});
2405 elsif ($field =~ /^(?:fixed|found)_versions$/) {
2406 next if join(' ', sort @{$data->{$field}}) eq
2407 join(' ',sort keys %{$merge_status->{$field}});
2409 elsif ($field eq 'done') {
2410 # for done, we only care if the bug is done or not
2411 # done, not the value it's set to.
2412 if (defined $merge_status->{$field} and length $merge_status->{$field} and
2413 defined $data->{$field} and length $data->{$field}) {
2416 elsif ((not defined $merge_status->{$field} or not length $merge_status->{$field}) and
2417 (not defined $data->{$field} or not length $data->{$field})
2422 elsif ($merge_status->{$field} eq $data->{$field}) {
2427 bug => $data->{bug_num},
2428 orig_value => $data->{$field},
2430 (exists $force_functions{$field}{modify_value} ?
2431 $force_functions{$field}{modify_value}->($merge_status->{$field}):
2432 $merge_status->{$field}),
2433 value => $merge_status->{$field},
2434 function => $force_functions{$field}{func},
2435 key => $force_functions{$field}{key},
2436 options => $force_functions{$field}{options},
2437 allowed => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0,
2439 $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
2440 $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
2441 if ($param->{force} or $change->{allowed}) {
2442 if ($field ne 'package' or $change->{allowed}) {
2443 push @{$changes{$data->{bug_num}}},$change;
2446 if ($param->{allow_reassign}) {
2447 if ($param->{reassign_different_sources}) {
2448 push @{$changes{$data->{bug_num}}},$change;
2451 # allow reassigning if binary_to_source returns at
2452 # least one of the same source packages
2453 my @merge_status_source =
2454 binary_to_source(package => $merge_status->{package},
2457 my @other_bug_source =
2458 binary_to_source(package => $data->{package},
2461 my %merge_status_sources;
2462 @merge_status_sources{@merge_status_source} =
2463 (1) x @merge_status_source;
2464 if (grep {$merge_status_sources{$_}} @other_bug_source) {
2465 push @{$changes{$data->{bug_num}}},$change;
2470 push @disallowed_changes,$change;
2472 # blocks and blocked by are weird; we have to go through and
2473 # set blocks to the other half of the merged bugs
2475 return (\@disallowed_changes,\%changes);
2481 affects(bug => $ref,
2482 transcript => $transcript,
2483 ($dl > 0 ? (debug => $transcript):()),
2484 requester => $header{from},
2485 request_addr => $controlrequestaddr,
2487 affected_packages => \%affected_packages,
2488 recipients => \%recipients,
2496 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2499 This marks a bug as affecting packages which the bug is not actually
2500 in. This should only be used in cases where fixing the bug instantly
2501 resolves the problem in the other packages.
2503 By default, the packages are set to the list of packages passed.
2504 However, if you pass add => 1 or remove => 1, the list of packages
2505 passed are added or removed from the affects list, respectively.
2510 my %param = validate_with(params => \@_,
2511 spec => {bug => {type => SCALAR,
2514 # specific options here
2515 package => {type => SCALAR|ARRAYREF|UNDEF,
2518 add => {type => BOOLEAN,
2521 remove => {type => BOOLEAN,
2525 %append_action_options,
2528 if ($param{add} and $param{remove}) {
2529 croak "Asking to both add and remove affects is nonsensical";
2531 if (not defined $param{package}) {
2532 $param{package} = [];
2535 __begin_control(%param,
2536 command => 'affects'
2538 my ($debug,$transcript) =
2539 @info{qw(debug transcript)};
2540 my @data = @{$info{data}};
2541 my @bugs = @{$info{bugs}};
2543 for my $data (@data) {
2545 print {$debug} "Going to change affects\n";
2546 my @packages = splitpackages($data->{affects});
2548 @packages{@packages} = (1) x @packages;
2551 for my $package (make_list($param{package})) {
2552 next unless defined $package and length $package;
2553 if (not $packages{$package}) {
2554 $packages{$package} = 1;
2555 push @added,$package;
2559 $action = "Added indication that $data->{bug_num} affects ".
2560 english_join(\@added);
2563 elsif ($param{remove}) {
2565 for my $package (make_list($param{package})) {
2566 if ($packages{$package}) {
2567 next unless defined $package and length $package;
2568 delete $packages{$package};
2569 push @removed,$package;
2572 $action = "Removed indication that $data->{bug_num} affects " .
2573 english_join(\@removed);
2576 my %added_packages = ();
2577 my %removed_packages = %packages;
2579 for my $package (make_list($param{package})) {
2580 next unless defined $package and length $package;
2581 $packages{$package} = 1;
2582 delete $removed_packages{$package};
2583 $added_packages{$package} = 1;
2585 if (keys %removed_packages) {
2586 $action = "Removed indication that $data->{bug_num} affects ".
2587 english_join([keys %removed_packages]);
2588 $action .= "\n" if keys %added_packages;
2590 if (keys %added_packages) {
2591 $action .= "Added indication that $data->{bug_num} affects " .
2592 english_join([keys %added_packages]);
2595 if (not length $action) {
2596 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n";
2599 my $old_data = dclone($data);
2600 $data->{affects} = join(',',keys %packages);
2601 append_action_to_log(bug => $data->{bug_num},
2603 command => 'affects',
2605 old_data => $old_data,
2606 __return_append_to_log_options(
2611 if not exists $param{append_log} or $param{append_log};
2612 writebug($data->{bug_num},$data);
2613 print {$transcript} "$action\n";
2615 __end_control(%info);
2619 =head1 SUMMARY FUNCTIONS
2624 summary(bug => $ref,
2625 transcript => $transcript,
2626 ($dl > 0 ? (debug => $transcript):()),
2627 requester => $header{from},
2628 request_addr => $controlrequestaddr,
2630 affected_packages => \%affected_packages,
2631 recipients => \%recipients,
2637 print {$transcript} "Failed to mark $ref with summary foo: $@";
2640 Handles all setting of summary fields
2642 If summary is undef, unsets the summary
2644 If summary is 0, sets the summary to the first paragraph contained in
2647 If summary is a positive integer, sets the summary to the message specified.
2649 Otherwise, sets summary to the value passed.
2655 my %param = validate_with(params => \@_,
2656 spec => {bug => {type => SCALAR,
2659 # specific options here
2660 summary => {type => SCALAR|UNDEF,
2664 %append_action_options,
2667 # croak "summary must be numeric or undef" if
2668 # defined $param{summary} and not $param{summary} =~ /^\d+/;
2670 __begin_control(%param,
2671 command => 'summary'
2673 my ($debug,$transcript) =
2674 @info{qw(debug transcript)};
2675 my @data = @{$info{data}};
2676 my @bugs = @{$info{bugs}};
2677 # figure out the log that we're going to use
2679 my $summary_msg = '';
2681 if (not defined $param{summary}) {
2683 print {$debug} "Removing summary fields\n";
2684 $action = 'Removed summary';
2686 elsif ($param{summary} =~ /^\d+$/) {
2688 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2689 if ($param{summary} == 0) {
2690 $log = $param{message};
2691 $summary_msg = @records + 1;
2694 if (($param{summary} - 1 ) > $#records) {
2695 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2697 my $record = $records[($param{summary} - 1 )];
2698 if ($record->{type} !~ /incoming-recv|recips/) {
2699 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2701 $summary_msg = $param{summary};
2702 $log = [$record->{text}];
2704 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2705 my $body = $p_o->{body};
2706 my $in_pseudoheaders = 0;
2708 # walk through body until we get non-blank lines
2709 for my $line (@{$body}) {
2710 if ($line =~ /^\s*$/) {
2711 if (length $paragraph) {
2712 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2718 $in_pseudoheaders = 0;
2721 # skip a paragraph if it looks like it's control or
2723 if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2724 $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2725 \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2726 debug|(?:not|)forwarded|priority|
2727 (?:un|)block|limit|(?:un|)archive|
2728 reassign|retitle|affects|wrongpackage
2729 (?:un|force|)merge|user(?:category|tags?|)
2731 if (not length $paragraph) {
2732 print {$debug} "Found control/pseudo-headers and skiping them\n";
2733 $in_pseudoheaders = 1;
2737 next if $in_pseudoheaders;
2738 $paragraph .= $line ." \n";
2740 print {$debug} "Summary is going to be '$paragraph'\n";
2741 $summary = $paragraph;
2742 $summary =~ s/[\n\r]/ /g;
2743 if (not length $summary) {
2744 die "Unable to find summary message to use";
2746 # trim off a trailing spaces
2747 $summary =~ s/\ *$//;
2750 $summary = $param{summary};
2752 for my $data (@data) {
2753 print {$debug} "Going to change summary\n";
2754 if (((not defined $summary or not length $summary) and
2755 (not defined $data->{summary} or not length $data->{summary})) or
2756 $summary eq $data->{summary}) {
2757 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n";
2760 if (length $summary) {
2761 if (length $data->{summary}) {
2762 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2765 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2768 my $old_data = dclone($data);
2769 $data->{summary} = $summary;
2770 append_action_to_log(bug => $data->{bug_num},
2771 command => 'summary',
2772 old_data => $old_data,
2775 __return_append_to_log_options(
2780 if not exists $param{append_log} or $param{append_log};
2781 writebug($data->{bug_num},$data);
2782 print {$transcript} "$action\n";
2784 __end_control(%info);
2792 clone_bug(bug => $ref,
2793 transcript => $transcript,
2794 ($dl > 0 ? (debug => $transcript):()),
2795 requester => $header{from},
2796 request_addr => $controlrequestaddr,
2798 affected_packages => \%affected_packages,
2799 recipients => \%recipients,
2804 print {$transcript} "Failed to clone bug $ref bar: $@";
2807 Clones the given bug.
2809 We currently don't support cloning merged bugs, but this could be
2810 handled by internally unmerging, cloning, then remerging the bugs.
2815 my %param = validate_with(params => \@_,
2816 spec => {bug => {type => SCALAR,
2819 new_bugs => {type => ARRAYREF,
2821 new_clones => {type => HASHREF,
2825 %append_action_options,
2829 __begin_control(%param,
2832 my ($debug,$transcript) =
2833 @info{qw(debug transcript)};
2834 my @data = @{$info{data}};
2835 my @bugs = @{$info{bugs}};
2838 for my $data (@data) {
2839 if (length($data->{mergedwith})) {
2840 die "Bug is marked as being merged with others. Use an existing clone.\n";
2844 die "Not exactly one bug‽ This shouldn't happen.";
2846 my $data = $data[0];
2848 for my $newclone_id (@{$param{new_bugs}}) {
2849 my $new_bug_num = new_bug(copy => $data->{bug_num});
2850 $param{new_clones}{$newclone_id} = $new_bug_num;
2851 $clones{$newclone_id} = $new_bug_num;
2853 my @new_bugs = sort values %clones;
2855 for my $new_bug (@new_bugs) {
2856 # no collapsed ids or the higher collapsed id is not one less
2857 # than the next highest new bug
2858 if (not @collapsed_ids or
2859 $collapsed_ids[-1][1]+1 != $new_bug) {
2860 push @collapsed_ids,[$new_bug,$new_bug];
2863 $collapsed_ids[-1][1] = $new_bug;
2867 for my $ci (@collapsed_ids) {
2868 if ($ci->[0] == $ci->[1]) {
2869 push @collapsed,$ci->[0];
2872 push @collapsed,$ci->[0].'-'.$ci->[1]
2875 my $collapsed_str = english_join(\@collapsed);
2876 $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2877 for my $new_bug (@new_bugs) {
2878 append_action_to_log(bug => $new_bug,
2880 __return_append_to_log_options(
2885 if not exists $param{append_log} or $param{append_log};
2887 append_action_to_log(bug => $data->{bug_num},
2889 __return_append_to_log_options(
2894 if not exists $param{append_log} or $param{append_log};
2895 writebug($data->{bug_num},$data);
2896 print {$transcript} "$action\n";
2897 __end_control(%info);
2898 # bugs that this bug is blocking are also blocked by the new clone(s)
2899 for my $bug (split ' ', $data->{blocks}) {
2900 for my $new_bug (@new_bugs) {
2901 set_blocks(bug => $new_bug,
2904 keys %common_options,
2905 keys %append_action_options),
2909 # bugs that this bug is blocked by are also blocking the new clone(s)
2910 for my $bug (split ' ', $data->{blockedby}) {
2911 for my $new_bug (@new_bugs) {
2912 set_blocks(bug => $bug,
2915 keys %common_options,
2916 keys %append_action_options),
2924 =head1 OWNER FUNCTIONS
2930 transcript => $transcript,
2931 ($dl > 0 ? (debug => $transcript):()),
2932 requester => $header{from},
2933 request_addr => $controlrequestaddr,
2935 recipients => \%recipients,
2941 print {$transcript} "Failed to mark $ref as having an owner: $@";
2944 Handles all setting of the owner field; given an owner of undef or of
2945 no length, indicates that a bug is not owned by anyone.
2950 my %param = validate_with(params => \@_,
2951 spec => {bug => {type => SCALAR,
2954 owner => {type => SCALAR|UNDEF,
2957 %append_action_options,
2961 __begin_control(%param,
2964 my ($debug,$transcript) =
2965 @info{qw(debug transcript)};
2966 my @data = @{$info{data}};
2967 my @bugs = @{$info{bugs}};
2969 for my $data (@data) {
2970 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2971 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2972 if (not defined $param{owner} or not length $param{owner}) {
2973 if (not defined $data->{owner} or not length $data->{owner}) {
2974 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n";
2978 $action = "Removed annotation that $config{bug} was owned by " .
2982 if ($data->{owner} eq $param{owner}) {
2983 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2986 if (length $data->{owner}) {
2987 $action = "Owner changed from $data->{owner} to $param{owner}.";
2990 $action = "Owner recorded as $param{owner}."
2993 my $old_data = dclone($data);
2994 $data->{owner} = $param{owner};
2995 append_action_to_log(bug => $data->{bug_num},
2998 old_data => $old_data,
3000 __return_append_to_log_options(
3005 if not exists $param{append_log} or $param{append_log};
3006 writebug($data->{bug_num},$data);
3007 print {$transcript} "$action\n";
3009 __end_control(%info);
3013 =head1 ARCHIVE FUNCTIONS
3020 bug_archive(bug => $bug_num,
3022 transcript => \$transcript,
3027 transcript("Unable to archive $bug_num\n");
3030 transcript($transcript);
3033 This routine archives a bug
3037 =item bug -- bug number
3039 =item check_archiveable -- check wether a bug is archiveable before
3040 archiving; defaults to 1
3042 =item archive_unarchived -- whether to archive bugs which have not
3043 previously been archived; defaults to 1. [Set to 0 when used from
3046 =item ignore_time -- whether to ignore time constraints when archiving
3047 a bug; defaults to 0.
3054 my %param = validate_with(params => \@_,
3055 spec => {bug => {type => SCALAR,
3058 check_archiveable => {type => BOOLEAN,
3061 archive_unarchived => {type => BOOLEAN,
3064 ignore_time => {type => BOOLEAN,
3068 %append_action_options,
3071 my %info = __begin_control(%param,
3072 command => 'archive',
3074 my ($debug,$transcript) = @info{qw(debug transcript)};
3075 my @data = @{$info{data}};
3076 my @bugs = @{$info{bugs}};
3077 my $action = "$config{bug} archived.";
3078 if ($param{check_archiveable} and
3079 not bug_archiveable(bug=>$param{bug},
3080 ignore_time => $param{ignore_time},
3082 print {$transcript} "Bug $param{bug} cannot be archived\n";
3083 die "Bug $param{bug} cannot be archived";
3085 if (not $param{archive_unarchived} and
3086 not exists $data[0]{unarchived}
3088 print {$transcript} "$param{bug} has not been archived previously\n";
3089 die "$param{bug} has not been archived previously";
3091 add_recipients(recipients => $param{recipients},
3094 transcript => $transcript,
3096 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3097 for my $bug (@bugs) {
3098 if ($param{check_archiveable}) {
3099 die "Bug $bug cannot be archived (but $param{bug} can?)"
3100 unless bug_archiveable(bug=>$bug,
3101 ignore_time => $param{ignore_time},
3105 # If we get here, we can archive/remove this bug
3106 print {$debug} "$param{bug} removing\n";
3107 for my $bug (@bugs) {
3108 #print "$param{bug} removing $bug\n" if $debug;
3109 my $dir = get_hashname($bug);
3110 # First indicate that this bug is being archived
3111 append_action_to_log(bug => $bug,
3113 command => 'archive',
3114 # we didn't actually change the data
3115 # when we archived, so we don't pass
3116 # a real new_data or old_data
3119 __return_append_to_log_options(
3124 if not exists $param{append_log} or $param{append_log};
3125 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3126 if ($config{save_old_bugs}) {
3127 mkpath("$config{spool_dir}/archive/$dir");
3128 foreach my $file (@files_to_remove) {
3129 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3130 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3131 # we need to bail out here if things have
3132 # gone horribly wrong to avoid removing a
3134 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3137 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3139 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3140 print {$debug} "deleted $bug (from $param{bug})\n";
3142 bughook_archive(@bugs);
3143 __end_control(%info);
3146 =head2 bug_unarchive
3150 bug_unarchive(bug => $bug_num,
3152 transcript => \$transcript,
3157 transcript("Unable to archive bug: $bug_num");
3159 transcript($transcript);
3161 This routine unarchives a bug
3166 my %param = validate_with(params => \@_,
3167 spec => {bug => {type => SCALAR,
3171 %append_action_options,
3175 my %info = __begin_control(%param,
3177 command=>'unarchive');
3178 my ($debug,$transcript) =
3179 @info{qw(debug transcript)};
3180 my @data = @{$info{data}};
3181 my @bugs = @{$info{bugs}};
3182 my $action = "$config{bug} unarchived.";
3183 my @files_to_remove;
3184 for my $bug (@bugs) {
3185 print {$debug} "$param{bug} removing $bug\n";
3186 my $dir = get_hashname($bug);
3187 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3188 mkpath("archive/$dir");
3189 foreach my $file (@files_to_copy) {
3190 # die'ing here sucks
3191 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3192 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3193 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3195 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3196 print {$transcript} "Unarchived $config{bug} $bug\n";
3198 unlink(@files_to_remove) or die "Unable to unlink bugs";
3199 # Indicate that this bug has been archived previously
3200 for my $bug (@bugs) {
3201 my $newdata = readbug($bug);
3202 my $old_data = dclone($newdata);
3203 if (not defined $newdata) {
3204 print {$transcript} "$config{bug} $bug disappeared!\n";
3205 die "Bug $bug disappeared!";
3207 $newdata->{unarchived} = time;
3208 append_action_to_log(bug => $bug,
3210 command => 'unarchive',
3211 new_data => $newdata,
3212 old_data => $old_data,
3213 __return_append_to_log_options(
3218 if not exists $param{append_log} or $param{append_log};
3219 writebug($bug,$newdata);
3221 __end_control(%info);
3224 =head2 append_action_to_log
3226 append_action_to_log
3228 This should probably be moved to Debbugs::Log; have to think that out
3233 sub append_action_to_log{
3234 my %param = validate_with(params => \@_,
3235 spec => {bug => {type => SCALAR,
3238 new_data => {type => HASHREF,
3241 old_data => {type => HASHREF,
3244 command => {type => SCALAR,
3247 action => {type => SCALAR,
3249 requester => {type => SCALAR,
3252 request_addr => {type => SCALAR,
3255 location => {type => SCALAR,
3258 message => {type => SCALAR|ARRAYREF,
3261 recips => {type => SCALAR|ARRAYREF,
3264 desc => {type => SCALAR,
3267 get_lock => {type => BOOLEAN,
3270 locks => {type => HASHREF,
3274 # append_action_options here
3275 # because some of these
3276 # options aren't actually
3277 # optional, even though the
3278 # original function doesn't
3282 # Fix this to use $param{location}
3283 my $log_location = buglog($param{bug});
3284 die "Unable to find .log for $param{bug}"
3285 if not defined $log_location;
3286 if ($param{get_lock}) {
3287 filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3291 my $logfh = IO::File->new(">>$log_location") or
3292 die "Unable to open $log_location for appending: $!";
3293 # determine difference between old and new
3295 if (exists $param{old_data} and exists $param{new_data}) {
3296 my $old_data = dclone($param{old_data});
3297 my $new_data = dclone($param{new_data});
3298 for my $key (keys %{$old_data}) {
3299 if (not exists $Debbugs::Status::fields{$key}) {
3300 delete $old_data->{$key};
3303 next unless exists $new_data->{$key};
3304 next unless defined $new_data->{$key};
3305 if (not defined $old_data->{$key}) {
3306 delete $old_data->{$key};
3309 if (ref($new_data->{$key}) and
3310 ref($old_data->{$key}) and
3311 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3312 local $Storable::canonical = 1;
3313 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3314 delete $new_data->{$key};
3315 delete $old_data->{$key};
3318 elsif ($new_data->{$key} eq $old_data->{$key}) {
3319 delete $new_data->{$key};
3320 delete $old_data->{$key};
3323 for my $key (keys %{$new_data}) {
3324 if (not exists $Debbugs::Status::fields{$key}) {
3325 delete $new_data->{$key};
3328 next unless exists $old_data->{$key};
3329 next unless defined $old_data->{$key};
3330 if (not defined $new_data->{$key} or
3331 not exists $Debbugs::Status::fields{$key}) {
3332 delete $new_data->{$key};
3335 if (ref($new_data->{$key}) and
3336 ref($old_data->{$key}) and
3337 ref($new_data->{$key}) eq ref($old_data->{$key})) {
3338 local $Storable::canonical = 1;
3339 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3340 delete $new_data->{$key};
3341 delete $old_data->{$key};
3344 elsif ($new_data->{$key} eq $old_data->{$key}) {
3345 delete $new_data->{$key};
3346 delete $old_data->{$key};
3349 $data_diff .= "<!-- new_data:\n";
3351 for my $key (keys %{$new_data}) {
3352 if (not exists $Debbugs::Status::fields{$key}) {
3353 warn "No such field $key";
3356 $nd{$key} = $new_data->{$key};
3357 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3359 $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%nd)],[qw(new_data)]));
3360 $data_diff .= "-->\n";
3361 $data_diff .= "<!-- old_data:\n";
3363 for my $key (keys %{$old_data}) {
3364 if (not exists $Debbugs::Status::fields{$key}) {
3365 warn "No such field $key";
3368 $od{$key} = $old_data->{$key};
3369 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3371 $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%od)],[qw(old_data)]));
3372 $data_diff .= "-->\n";
3375 (exists $param{command} ?
3376 "<!-- command:".html_escape(encode_utf8($param{command}))." -->\n":""
3378 (length $param{requester} ?
3379 "<!-- requester: ".html_escape(encode_utf8($param{requester}))." -->\n":""
3381 (length $param{request_addr} ?
3382 "<!-- request_addr: ".html_escape(encode_utf8($param{request_addr}))." -->\n":""
3384 "<!-- time:".time()." -->\n",
3386 "<strong>".html_escape(encode_utf8($param{action}))."</strong>\n");
3387 if (length $param{requester}) {
3388 $msg .= "Request was from <code>".html_escape(encode_utf8($param{requester}))."</code>\n";
3390 if (length $param{request_addr}) {
3391 $msg .= "to <code>".html_escape(encode_utf8($param{request_addr}))."</code>";
3393 if (length $param{desc}) {
3394 $msg .= ":<br>\n".encode_utf8($param{desc})."\n";
3399 push @records, {type => 'html',
3403 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3404 push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3405 exists $param{recips}?(recips => [make_list($param{recips})]):(),
3406 text => join('',make_list($param{message})),
3409 write_log_records(logfh=>$logfh,
3410 records => \@records,
3412 close $logfh or die "Unable to close $log_location: $!";
3413 if ($param{get_lock}) {
3414 unfilelock(exists $param{locks}?$param{locks}:());
3422 =head1 PRIVATE FUNCTIONS
3424 =head2 __handle_affected_packages
3426 __handle_affected_packages(affected_packages => {},
3434 sub __handle_affected_packages{
3435 my %param = validate_with(params => \@_,
3436 spec => {%common_options,
3437 data => {type => ARRAYREF|HASHREF
3442 for my $data (make_list($param{data})) {
3443 next unless exists $data->{package} and defined $data->{package};
3444 my @packages = split /\s*,\s*/,$data->{package};
3445 @{$param{affected_packages}}{@packages} = (1) x @packages;
3449 =head2 __handle_debug_transcript
3451 my ($debug,$transcript) = __handle_debug_transcript(%param);
3453 Returns a debug and transcript filehandle
3458 sub __handle_debug_transcript{
3459 my %param = validate_with(params => \@_,
3460 spec => {%common_options},
3463 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3464 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3465 return ($debug,$transcript);
3472 Produces a small bit of bug information to kick out to the transcript
3479 next unless defined $data and exists $data->{bug_num};
3480 $return .= "Bug #".($data->{bug_num}||'').
3481 ((defined $data->{done} and length $data->{done})?
3482 " {Done: $data->{done}}":''
3484 " [".($data->{package}||'(no package)'). "] ".
3485 ($data->{subject}||'(no subject)')."\n";
3491 =head2 __internal_request
3493 __internal_request()
3494 __internal_request($level)
3496 Returns true if the caller of the function calling __internal_request
3497 belongs to __PACKAGE__
3499 This allows us to be magical, and don't bother to print bug info if
3500 the second caller is from this package, amongst other things.
3502 An optional level is allowed, which increments the number of levels to
3503 check by the given value. [This is basically for use by internal
3504 functions like __begin_control which are always called by
3509 sub __internal_request{
3511 $l = 0 if not defined $l;
3512 if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3518 sub __return_append_to_log_options{
3520 my $action = $param{action} if exists $param{action};
3521 if (not exists $param{requester}) {
3522 $param{requester} = $config{control_internal_requester};
3524 if (not exists $param{request_addr}) {
3525 $param{request_addr} = $config{control_internal_request_addr};
3527 if (not exists $param{message}) {
3528 my $date = rfc822_date();
3529 $param{message} = fill_in_template(template => 'mail/fake_control_message',
3530 variables => {request_addr => $param{request_addr},
3531 requester => $param{requester},
3537 if (not defined $action) {
3538 carp "Undefined action!";
3539 $action = "unknown action";
3541 return (action => $action,
3542 hash_slice(%param,keys %append_action_options),
3546 =head2 __begin_control
3548 my %info = __begin_control(%param,
3550 command=>'unarchive');
3551 my ($debug,$transcript) = @info{qw(debug transcript)};
3552 my @data = @{$info{data}};
3553 my @bugs = @{$info{bugs}};
3556 Starts the process of modifying a bug; handles all of the generic
3557 things that almost every control request needs
3559 Returns a hash containing
3563 =item new_locks -- number of new locks taken out by this call
3565 =item debug -- the debug file handle
3567 =item transcript -- the transcript file handle
3569 =item data -- an arrayref containing the data of the bugs
3570 corresponding to this request
3572 =item bugs -- an arrayref containing the bug numbers of the bugs
3573 corresponding to this request
3581 sub __begin_control {
3582 my %param = validate_with(params => \@_,
3583 spec => {bug => {type => SCALAR,
3586 archived => {type => BOOLEAN,
3589 command => {type => SCALAR,
3597 my ($debug,$transcript) = __handle_debug_transcript(@_);
3598 print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n";
3599 # print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n";
3600 $lockhash = $param{locks} if exists $param{locks};
3602 my $old_die = $SIG{__DIE__};
3603 $SIG{__DIE__} = *sig_die{CODE};
3605 ($new_locks, @data) =
3606 lock_read_all_merged_bugs(bug => $param{bug},
3607 $param{archived}?(location => 'archive'):(),
3608 exists $param{locks} ? (locks => $param{locks}):(),
3610 $locks += $new_locks;
3612 die "Unable to read any bugs successfully.";
3614 if (not $param{archived}) {
3615 for my $data (@data) {
3616 if ($data->{archived}) {
3617 die "Not altering archived bugs; see unarchive.";
3621 if (not __check_limit(data => \@data,
3622 exists $param{limit}?(limit => $param{limit}):(),
3623 transcript => $transcript,
3625 die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3628 __handle_affected_packages(%param,data => \@data);
3629 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3630 print {$debug} "$param{bug} read $locks locks\n";
3631 if (not @data or not defined $data[0]) {
3632 print {$transcript} "No bug found for $param{bug}\n";
3633 die "No bug found for $param{bug}";
3636 add_recipients(data => \@data,
3637 recipients => $param{recipients},
3638 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3640 (__internal_request()?(transcript => $transcript):()),
3643 print {$debug} "$param{bug} read done\n";
3644 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3645 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3646 return (data => \@data,
3648 old_die => $old_die,
3649 new_locks => $new_locks,
3651 transcript => $transcript,
3653 exists $param{locks}?(locks => $param{locks}):(),
3657 =head2 __end_control
3659 __end_control(%info);
3661 Handles tearing down from a control request
3667 if (exists $info{new_locks} and $info{new_locks} > 0) {
3668 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3669 for (1..$info{new_locks}) {
3670 unfilelock(exists $info{locks}?$info{locks}:());
3674 $SIG{__DIE__} = $info{old_die};
3675 if (exists $info{param}{affected_bugs}) {
3676 @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3678 add_recipients(recipients => $info{param}{recipients},
3679 (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3680 data => $info{data},
3681 debug => $info{debug},
3682 transcript => $info{transcript},
3684 __handle_affected_packages(%{$info{param}},data=>$info{data});
3688 =head2 __check_limit
3690 __check_limit(data => \@data, limit => $param{limit});
3693 Checks to make sure that bugs match any limits; each entry of @data
3694 much satisfy the limit.
3696 Returns true if there are no entries in data, or there are no keys in
3697 limit; returns false (0) if there are any entries which do not match.
3699 The limit hashref elements can contain an arrayref of scalars to
3700 match; regexes are also acccepted. At least one of the entries in each
3701 element needs to match the corresponding field in all data for the
3708 my %param = validate_with(params => \@_,
3709 spec => {data => {type => ARRAYREF|SCALAR,
3711 limit => {type => HASHREF|UNDEF,
3713 transcript => {type => SCALARREF|HANDLE,
3718 my @data = make_list($param{data});
3720 not defined $param{limit} or
3721 not keys %{$param{limit}}) {
3724 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3725 my $going_to_fail = 0;
3726 for my $data (@data) {
3727 $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3728 status => dclone($data),
3730 for my $field (keys %{$param{limit}}) {
3731 next unless exists $param{limit}{$field};
3733 my @data_fields = make_list($data->{$field});
3734 LIMIT: for my $limit (make_list($param{limit}{$field})) {
3735 if (not ref $limit) {
3736 for my $data_field (@data_fields) {
3737 if ($data_field eq $limit) {
3743 elsif (ref($limit) eq 'Regexp') {
3744 for my $data_field (@data_fields) {
3745 if ($data_field =~ $limit) {
3752 warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3757 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3758 "' does not match at least one of ".
3759 join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3763 return $going_to_fail?0:1;
3771 We override die to specially handle unlocking files in the cases where
3772 we are called via eval. [If we're not called via eval, it doesn't
3778 if ($^S) { # in eval
3780 for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3787 # =head2 __message_body_template
3789 # message_body_template('mail/ack',{ref=>'foo'});
3791 # Creates a message body using a template
3795 sub __message_body_template{
3796 my ($template,$extra_var) = @_;
3798 my $hole_var = {'&bugurl' =>
3800 'http://'.$config{cgi_domain}.'/'.
3801 Debbugs::CGI::bug_url($_[0]);
3805 my $body = fill_in_template(template => $template,
3806 variables => {config => \%config,
3809 hole_var => $hole_var,
3811 return fill_in_template(template => 'mail/message_body',
3812 variables => {config => \%config,
3816 hole_var => $hole_var,
3820 sub __all_undef_or_equal {
3822 return 1 if @values == 1 or @values == 0;
3823 my $not_def = grep {not defined $_} @values;
3824 if ($not_def == @values) {
3827 if ($not_def > 0 and $not_def != @values) {
3830 my $first_val = shift @values;
3831 for my $val (@values) {
3832 if ($first_val ne $val) {