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 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 location -- Optional location; currently ignored but may be
53 supported in the future for updating archived bugs upon archival
55 =item message -- The original message which caused the action to be taken
57 =item append_log -- Whether or not to append information to the log.
61 B<append_log> (for most functions) is a special option. When set to
62 false, no appending to the log is done at all. When it is not present,
63 the above information is faked, and appended to the log file. When it
64 is true, the above options must be present, and their values are used.
67 =head1 GENERAL FUNCTIONS
73 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
74 use base qw(Exporter);
78 $DEBUG = 0 unless defined $DEBUG;
81 %EXPORT_TAGS = (affects => [qw(affects)],
82 summary => [qw(summary)],
84 title => [qw(set_title)],
85 forward => [qw(set_forwarded)],
86 found => [qw(set_found set_fixed)],
87 fixed => [qw(set_found set_fixed)],
88 package => [qw(set_package)],
89 archive => [qw(bug_archive bug_unarchive),
91 log => [qw(append_action_to_log),
95 Exporter::export_ok_tags(keys %EXPORT_TAGS);
96 $EXPORT_TAGS{all} = [@EXPORT_OK];
99 use Debbugs::Config qw(:config);
100 use Debbugs::Common qw(:lock buglog :misc get_hashname);
101 use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages);
102 use Debbugs::CGI qw(html_escape);
103 use Debbugs::Log qw(:misc);
104 use Debbugs::Recipients qw(:add);
105 use Debbugs::Packages qw(:versions :mapping);
107 use Params::Validate qw(validate_with :types);
108 use File::Path qw(mkpath);
111 use Debbugs::Text qw(:templates);
113 use Debbugs::Mail qw(rfc822_date);
115 use Mail::RFC822::Address qw();
117 use POSIX qw(strftime);
119 use Storable qw(dclone nfreeze);
123 # These are a set of options which are common to all of these functions
125 my %common_options = (debug => {type => SCALARREF|HANDLE,
128 transcript => {type => SCALARREF|HANDLE,
131 affected_bugs => {type => HASHREF,
134 affected_packages => {type => HASHREF,
137 recipients => {type => HASHREF,
140 limit => {type => HASHREF,
143 show_bug_info => {type => BOOLEAN,
149 my %append_action_options =
150 (action => {type => SCALAR,
153 requester => {type => SCALAR,
156 request_addr => {type => SCALAR,
159 location => {type => SCALAR,
162 message => {type => SCALAR|ARRAYREF,
165 append_log => {type => BOOLEAN,
167 depends => [qw(requester request_addr),
174 # this is just a generic stub for Debbugs::Control functions.
179 # set_foo(bug => $ref,
180 # transcript => $transcript,
181 # ($dl > 0 ? (debug => $transcript):()),
182 # requester => $header{from},
183 # request_addr => $controlrequestaddr,
185 # affected_packages => \%affected_packages,
186 # recipients => \%recipients,
192 # print {$transcript} "Failed to set foo $ref bar: $@";
200 ## my %param = validate_with(params => \@_,
201 ## spec => {bug => {type => SCALAR,
202 ## regex => qr/^\d+$/,
204 ## # specific options here
206 ## %append_action_options,
210 ## __begin_control(%param,
213 ## my ($new_locks,$debug,$transcript) =
214 ## @info{qw(new_locks debug transcript)};
215 ## my @data = @{$info{data}};
216 ## my @bugs = @{$info{bugs}};
218 ## for my $data (@data) {
219 ## append_action_to_log(bug => $data->{bug_num},
221 ## __return_append_to_log_options(
223 ## action => $action,
226 ## if not exists $param{append_log} or $param{append_log};
227 ## writebug($data->{bug_num},$data);
228 ## print {$transcript} "$action\n";
230 ## __end_control(\%info);
236 set_submitter(bug => $ref,
237 transcript => $transcript,
238 ($dl > 0 ? (debug => $transcript):()),
239 requester => $header{from},
240 request_addr => $controlrequestaddr,
242 affected_packages => \%affected_packages,
243 recipients => \%recipients,
244 submitter => $new_submitter,
245 notify_submitter => 1,
250 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
253 Sets the submitter of a bug. If notify_submitter is true (the
254 default), notifies the old submitter of a bug on changes
259 my %param = validate_with(params => \@_,
260 spec => {bug => {type => SCALAR,
263 # specific options here
264 submitter => {type => SCALAR,
266 notify_submitter => {type => BOOLEAN,
270 %append_action_options,
273 if (not Mail::RFC822::Address::valid($param{submitter})) {
274 die "New submitter address $param{submitter} is not a valid e-mail address";
277 __begin_control(%param,
278 command => 'submitter'
280 my ($new_locks,$debug,$transcript) =
281 @info{qw(new_locks debug transcript)};
282 my @data = @{$info{data}};
283 my @bugs = @{$info{bugs}};
285 # here we only concern ourselves with the first of the merged bugs
286 for my $data ($data[0]) {
287 my $old_data = dclone($data);
288 print {$debug} "Going to change bug submitter\n";
289 if (((not defined $param{submitter} or not length $param{submitter}) and
290 (not defined $data->{submitter} or not length $data->{submitter})) or
291 $param{submitter} eq $data->{submitter}) {
292 print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
293 unless __internal_request();
297 if (defined $data->{submitter} and length($data->{submitter})) {
298 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{submitter}'";
301 $action= "Set $config{bug} submitter to '$param{submitter}'.";
303 $data->{submitter} = $param{submitter};
305 append_action_to_log(bug => $data->{bug_num},
306 command => 'set_submitter',
308 old_data => $old_data,
310 __return_append_to_log_options(
315 if not exists $param{append_log} or $param{append_log};
316 writebug($data->{bug_num},$data);
317 print {$transcript} "$action\n";
319 __end_control(%info);
327 set_forwarded(bug => $ref,
328 transcript => $transcript,
329 ($dl > 0 ? (debug => $transcript):()),
330 requester => $header{from},
331 request_addr => $controlrequestaddr,
333 affected_packages => \%affected_packages,
334 recipients => \%recipients,
335 forwarded => $forward_to,
340 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
343 Sets the location to which a bug is forwarded. Given an undef
344 forwarded, unsets forwarded.
350 my %param = validate_with(params => \@_,
351 spec => {bug => {type => SCALAR,
354 # specific options here
355 forwarded => {type => SCALAR|UNDEF,
358 %append_action_options,
361 if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
362 die "Non-printable characters are not allowed in the forwarded field";
365 __begin_control(%param,
366 command => 'forwarded'
368 my ($new_locks,$debug,$transcript) =
369 @info{qw(new_locks debug transcript)};
370 my @data = @{$info{data}};
371 my @bugs = @{$info{bugs}};
373 for my $data (@data) {
374 my $old_data = dclone($data);
375 print {$debug} "Going to change bug forwarded\n";
376 if (((not defined $param{forwarded} or not length $param{forwarded}) and
377 (not defined $data->{forwarded} or not length $data->{forwarded})) or
378 $param{forwarded} eq $data->{forwarded}) {
379 print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
380 unless __internal_request();
384 if (not defined $param{forwarded}) {
385 $action= "Unset $config{bug} forwarded-to-address";
387 elsif (defined $data->{forwarded} and length($data->{forwarded})) {
388 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
391 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
393 $data->{forwarded} = $param{forwarded};
395 append_action_to_log(bug => $data->{bug_num},
396 command => 'set_forwarded',
398 old_data => $old_data,
400 __return_append_to_log_options(
405 if not exists $param{append_log} or $param{append_log};
406 writebug($data->{bug_num},$data);
407 print {$transcript} "$action\n";
409 __end_control(%info);
418 set_title(bug => $ref,
419 transcript => $transcript,
420 ($dl > 0 ? (debug => $transcript):()),
421 requester => $header{from},
422 request_addr => $controlrequestaddr,
424 affected_packages => \%affected_packages,
425 recipients => \%recipients,
431 print {$transcript} "Failed to set the title of $ref: $@";
434 Sets the title of a specific bug
440 my %param = validate_with(params => \@_,
441 spec => {bug => {type => SCALAR,
444 # specific options here
445 title => {type => SCALAR,
448 %append_action_options,
451 if ($param{title} =~ /[^[:print:]]/) {
452 die "Non-printable characters are not allowed in bug titles";
455 my %info = __begin_control(%param,
458 my ($debug,$transcript) =
459 @info{qw(debug transcript)};
460 my @data = @{$info{data}};
461 my @bugs = @{$info{bugs}};
463 for my $data (@data) {
464 my $old_data = dclone($data);
465 print {$debug} "Going to change bug title\n";
466 if (defined $data->{subject} and length($data->{subject}) and
467 $data->{subject} eq $param{title}) {
468 print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
469 unless __internal_request();
473 if (defined $data->{subject} and length($data->{subject})) {
474 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
476 $action= "Set $config{bug} title to '$param{title}'.";
478 $data->{subject} = $param{title};
480 append_action_to_log(bug => $data->{bug_num},
481 command => 'set_title',
483 old_data => $old_data,
485 __return_append_to_log_options(
490 if not exists $param{append_log} or $param{append_log};
491 writebug($data->{bug_num},$data);
492 print {$transcript} "$action\n";
494 __end_control(%info);
501 set_package(bug => $ref,
502 transcript => $transcript,
503 ($dl > 0 ? (debug => $transcript):()),
504 requester => $header{from},
505 request_addr => $controlrequestaddr,
507 affected_packages => \%affected_packages,
508 recipients => \%recipients,
509 package => $new_package,
515 print {$transcript} "Failed to assign or reassign $ref to a package: $@";
518 Indicates that a bug is in a particular package. If is_source is true,
519 indicates that the package is a source package. [Internally, this
520 causes src: to be prepended to the package name.]
522 The default for is_source is 0. As a special case, if the package
523 starts with 'src:', it is assumed to be a source package and is_source
526 The package option must match the package_name_re regex.
531 my %param = validate_with(params => \@_,
532 spec => {bug => {type => SCALAR,
535 # specific options here
536 package => {type => SCALAR|ARRAYREF,
538 is_source => {type => BOOLEAN,
542 %append_action_options,
545 my @new_packages = map {splitpackages($_)} make_list($param{package});
546 if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
547 croak "Invalid package name '".
548 join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
551 my %info = __begin_control(%param,
552 command => 'package',
554 my ($new_locks,$debug,$transcript) =
555 @info{qw(new_locks debug transcript)};
556 my @data = @{$info{data}};
557 my @bugs = @{$info{bugs}};
558 # clean up the new package
562 ($temp =~ s/^src:// or
563 $param{is_source}) ? 'src:'.$temp:$temp;
567 my $package_reassigned = 0;
568 for my $data (@data) {
569 my $old_data = dclone($data);
570 print {$debug} "Going to change assigned package\n";
571 if (defined $data->{package} and length($data->{package}) and
572 $data->{package} eq $new_package) {
573 print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
574 unless __internal_request();
578 if (defined $data->{package} and length($data->{package})) {
579 $package_reassigned = 1;
580 $action= "$config{bug} reassigned from package '$data->{package}'".
581 " to '$new_package'.";
583 $action= "$config{bug} assigned to package '$new_package'.";
585 $data->{package} = $new_package;
587 append_action_to_log(bug => $data->{bug_num},
588 command => 'set_package',
590 old_data => $old_data,
592 __return_append_to_log_options(
597 if not exists $param{append_log} or $param{append_log};
598 writebug($data->{bug_num},$data);
599 print {$transcript} "$action\n";
601 __end_control(%info);
602 # Only clear the fixed/found versions if the package has been
604 if ($package_reassigned) {
605 my @params_for_found_fixed =
606 map {exists $param{$_}?($_,$param{$_}):()}
608 keys %common_options,
609 keys %append_action_options,
611 set_found(found => [],
612 @params_for_found_fixed,
614 set_fixed(fixed => [],
615 @params_for_found_fixed,
623 set_found(bug => $ref,
624 transcript => $transcript,
625 ($dl > 0 ? (debug => $transcript):()),
626 requester => $header{from},
627 request_addr => $controlrequestaddr,
629 affected_packages => \%affected_packages,
630 recipients => \%recipients,
637 print {$transcript} "Failed to set found on $ref: $@";
641 Sets, adds, or removes the specified found versions of a package
643 If the version list is empty, and the bug is currently not "done",
644 causes the done field to be cleared.
646 If any of the versions added to found are greater than any version in
647 which the bug is fixed (or when the bug is found and there are no
648 fixed versions) the done field is cleared.
653 my %param = validate_with(params => \@_,
654 spec => {bug => {type => SCALAR,
657 # specific options here
658 found => {type => SCALAR|ARRAYREF,
661 add => {type => BOOLEAN,
664 remove => {type => BOOLEAN,
668 %append_action_options,
671 if ($param{add} and $param{remove}) {
672 croak "It's nonsensical to add and remove the same versions";
676 __begin_control(%param,
679 my ($new_locks,$debug,$transcript) =
680 @info{qw(new_locks debug transcript)};
681 my @data = @{$info{data}};
682 my @bugs = @{$info{bugs}};
684 for my $version (make_list($param{found})) {
685 next unless defined $version;
686 $versions{$version} =
687 [make_source_versions(package => [splitpackages($data[0]{package})],
688 warnings => $transcript,
691 versions => $version,
694 # This is really ugly, but it's what we have to do
695 if (not @{$versions{$version}}) {
696 print {$transcript} "Unable to make a source version for version '$version'\n";
699 if (not keys %versions and ($param{remove} or $param{add})) {
700 if ($param{remove}) {
701 print {$transcript} "Requested to remove no versions; doing nothing.\n";
704 print {$transcript} "Requested to add no versions; doing nothing.\n";
706 __end_control(%info);
709 # first things first, make the versions fully qualified source
711 for my $data (@data) {
712 # The 'done' field gets a bit weird with version tracking,
713 # because a bug may be closed by multiple people in different
714 # branches. Until we have something more flexible, we set it
715 # every time a bug is fixed, and clear it when a bug is found
716 # in a version greater than any version in which the bug is
717 # fixed or when a bug is found and there is no fixed version
718 my $action = 'Did not alter found versions';
719 my %found_added = ();
720 my %found_removed = ();
721 my %fixed_removed = ();
723 my $old_data = dclone($data);
724 if (not $param{add} and not $param{remove}) {
725 $found_removed{$_} = 1 for @{$data->{found_versions}};
726 $data->{found_versions} = [];
729 @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
731 @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
732 for my $version (keys %versions) {
734 my @svers = @{$versions{$version}};
738 for my $sver (@svers) {
739 if (not exists $found_versions{$sver}) {
740 $found_versions{$sver} = 1;
741 $found_added{$sver} = 1;
743 # if the found we are adding matches any fixed
744 # versions, remove them
745 my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
746 delete $fixed_versions{$_} for @temp;
747 $fixed_removed{$_} = 1 for @temp;
750 # We only care about reopening the bug if the bug is
752 if (defined $data->{done} and length $data->{done}) {
753 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
754 map {m{([^/]+)$}; $1;} @svers;
755 # determine if we need to reopen
756 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
757 map {m{([^/]+)$}; $1;} keys %fixed_versions;
758 if (not @fixed_order or
759 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
765 elsif ($param{remove}) {
766 # in the case of removal, we only concern ourself with
767 # the version passed, not the source version it maps
769 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
770 delete $found_versions{$_} for @temp;
771 $found_removed{$_} = 1 for @temp;
774 # set the keys to exactly these values
775 my @svers = @{$versions{$version}};
779 for my $sver (@svers) {
780 if (not exists $found_versions{$sver}) {
781 $found_versions{$sver} = 1;
782 if (exists $found_removed{$sver}) {
783 delete $found_removed{$sver};
786 $found_added{$sver} = 1;
793 $data->{found_versions} = [keys %found_versions];
794 $data->{fixed_versions} = [keys %fixed_versions];
797 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
798 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
799 # push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
800 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
801 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
803 $action .= " and reopened"
805 if (not $reopened and not @changed) {
806 print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
807 unless __internal_request();
811 append_action_to_log(bug => $data->{bug_num},
813 command => 'set_found',
814 old_data => $old_data,
816 __return_append_to_log_options(
821 if not exists $param{append_log} or $param{append_log};
822 writebug($data->{bug_num},$data);
823 print {$transcript} "$action\n";
825 __end_control(%info);
831 set_fixed(bug => $ref,
832 transcript => $transcript,
833 ($dl > 0 ? (debug => $transcript):()),
834 requester => $header{from},
835 request_addr => $controlrequestaddr,
837 affected_packages => \%affected_packages,
838 recipients => \%recipients,
846 print {$transcript} "Failed to set fixed on $ref: $@";
850 Sets, adds, or removes the specified found versions of a package
852 If the version list is empty, and the bug is currently not "done",
853 causes the done field to be cleared.
855 If any of the versions added to found are greater than any version in
856 which the bug is fixed (or when the bug is found and there are no
857 fixed versions) the done field is cleared.
862 my %param = validate_with(params => \@_,
863 spec => {bug => {type => SCALAR,
866 # specific options here
867 fixed => {type => SCALAR|ARRAYREF,
870 add => {type => BOOLEAN,
873 remove => {type => BOOLEAN,
876 reopen => {type => BOOLEAN,
880 %append_action_options,
883 if ($param{add} and $param{remove}) {
884 croak "It's nonsensical to add and remove the same versions";
887 __begin_control(%param,
890 my ($new_locks,$debug,$transcript) =
891 @info{qw(new_locks debug transcript)};
892 my @data = @{$info{data}};
893 my @bugs = @{$info{bugs}};
895 for my $version (make_list($param{fixed})) {
896 next unless defined $version;
897 $versions{$version} =
898 [make_source_versions(package => [splitpackages($data[0]{package})],
899 warnings => $transcript,
902 versions => $version,
905 # This is really ugly, but it's what we have to do
906 if (not @{$versions{$version}}) {
907 print {$transcript} "Unable to make a source version for version '$version'\n";
910 if (not keys %versions and ($param{remove} or $param{add})) {
911 if ($param{remove}) {
912 print {$transcript} "Requested to remove no versions; doing nothing.\n";
915 print {$transcript} "Requested to add no versions; doing nothing.\n";
917 __end_control(%info);
920 # first things first, make the versions fully qualified source
922 for my $data (@data) {
923 my $old_data = dclone($data);
924 # The 'done' field gets a bit weird with version tracking,
925 # because a bug may be closed by multiple people in different
926 # branches. Until we have something more flexible, we set it
927 # every time a bug is fixed, and clear it when a bug is found
928 # in a version greater than any version in which the bug is
929 # fixed or when a bug is found and there is no fixed version
930 my $action = 'Did not alter fixed versions';
931 my %found_added = ();
932 my %found_removed = ();
933 my %fixed_added = ();
934 my %fixed_removed = ();
936 if (not $param{add} and not $param{remove}) {
937 $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
938 $data->{fixed_versions} = [];
941 @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
943 @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
944 for my $version (keys %versions) {
946 my @svers = @{$versions{$version}};
950 for my $sver (@svers) {
951 if (not exists $fixed_versions{$sver}) {
952 $fixed_versions{$sver} = 1;
953 $fixed_added{$sver} = 1;
957 elsif ($param{remove}) {
958 # in the case of removal, we only concern ourself with
959 # the version passed, not the source version it maps
961 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
962 delete $fixed_versions{$_} for @temp;
963 $fixed_removed{$_} = 1 for @temp;
966 # set the keys to exactly these values
967 my @svers = @{$versions{$version}};
971 for my $sver (@svers) {
972 if (not exists $fixed_versions{$sver}) {
973 $fixed_versions{$sver} = 1;
974 if (exists $fixed_removed{$sver}) {
975 delete $fixed_removed{$sver};
978 $fixed_added{$sver} = 1;
985 $data->{found_versions} = [keys %found_versions];
986 $data->{fixed_versions} = [keys %fixed_versions];
988 # If we're supposed to consider reopening, reopen if the
989 # fixed versions are empty or the greatest found version
990 # is greater than the greatest fixed version
991 if ($param{reopen} and defined $data->{done}
992 and length $data->{done}) {
993 my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
994 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
995 # determine if we need to reopen
996 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
997 map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
998 if (not @fixed_order or
999 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1006 push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1007 push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1008 push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1009 push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1010 $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1012 $action .= " and reopened"
1014 if (not $reopened and not @changed) {
1015 print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1016 unless __internal_request();
1020 append_action_to_log(bug => $data->{bug_num},
1021 command => 'set_fixed',
1023 old_data => $old_data,
1025 __return_append_to_log_options(
1030 if not exists $param{append_log} or $param{append_log};
1031 writebug($data->{bug_num},$data);
1032 print {$transcript} "$action\n";
1034 __end_control(%info);
1042 affects(bug => $ref,
1043 transcript => $transcript,
1044 ($dl > 0 ? (debug => $transcript):()),
1045 requester => $header{from},
1046 request_addr => $controlrequestaddr,
1048 affected_packages => \%affected_packages,
1049 recipients => \%recipients,
1057 print {$transcript} "Failed to mark $ref as affecting $packages: $@";
1060 This marks a bug as affecting packages which the bug is not actually
1061 in. This should only be used in cases where fixing the bug instantly
1062 resolves the problem in the other packages.
1064 By default, the packages are set to the list of packages passed.
1065 However, if you pass add => 1 or remove => 1, the list of packages
1066 passed are added or removed from the affects list, respectively.
1071 my %param = validate_with(params => \@_,
1072 spec => {bug => {type => SCALAR,
1075 # specific options here
1076 packages => {type => SCALAR|ARRAYREF,
1079 add => {type => BOOLEAN,
1082 remove => {type => BOOLEAN,
1086 %append_action_options,
1089 if ($param{add} and $param{remove}) {
1090 croak "Asking to both add and remove affects is nonsensical";
1093 __begin_control(%param,
1094 command => 'affects'
1096 my ($new_locks,$debug,$transcript) =
1097 @info{qw(new_locks debug transcript)};
1098 my @data = @{$info{data}};
1099 my @bugs = @{$info{bugs}};
1101 for my $data (@data) {
1103 print {$debug} "Going to change affects\n";
1104 my @packages = splitpackages($data->{affects});
1106 @packages{@packages} = (1) x @packages;
1109 for my $package (make_list($param{packages})) {
1110 next unless defined $package and length $package;
1111 if (not $packages{$package}) {
1112 $packages{$package} = 1;
1113 push @added,$package;
1117 $action = "Added indication that $data->{bug_num} affects ".
1118 english_join(\@added);
1121 elsif ($param{remove}) {
1123 for my $package (make_list($param{packages})) {
1124 if ($packages{$package}) {
1125 next unless defined $package and length $package;
1126 delete $packages{$package};
1127 push @removed,$package;
1130 $action = "Removed indication that $data->{bug_num} affects " .
1131 english_join(\@removed);
1134 my %added_packages = ();
1135 my %removed_packages = %packages;
1137 for my $package (make_list($param{packages})) {
1138 next unless defined $package and length $package;
1139 $packages{$package} = 1;
1140 delete $removed_packages{$package};
1141 $added_packages{$package} = 1;
1143 if (keys %removed_packages) {
1144 $action = "Removed indication that $data->{bug_num} affects ".
1145 english_join([keys %removed_packages]);
1146 $action .= "\n" if keys %added_packages;
1148 if (keys %added_packages) {
1149 $action .= "Added indication that $data->{bug_num} affects " .
1150 english_join([%added_packages]);
1153 if (not length $action) {
1154 print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
1155 unless __internal_request();
1157 my $old_data = dclone($data);
1158 $data->{affects} = join(',',keys %packages);
1159 append_action_to_log(bug => $data->{bug_num},
1161 command => 'affects',
1163 old_data => $old_data,
1164 __return_append_to_log_options(
1169 if not exists $param{append_log} or $param{append_log};
1170 writebug($data->{bug_num},$data);
1171 print {$transcript} "$action\n";
1173 __end_control(%info);
1177 =head1 SUMMARY FUNCTIONS
1182 summary(bug => $ref,
1183 transcript => $transcript,
1184 ($dl > 0 ? (debug => $transcript):()),
1185 requester => $header{from},
1186 request_addr => $controlrequestaddr,
1188 affected_packages => \%affected_packages,
1189 recipients => \%recipients,
1195 print {$transcript} "Failed to mark $ref with summary foo: $@";
1198 Handles all setting of summary fields
1200 If summary is undef, unsets the summary
1202 If summary is 0, sets the summary to the first paragraph contained in
1205 If summary is numeric, sets the summary to the message specified.
1212 my %param = validate_with(params => \@_,
1213 spec => {bug => {type => SCALAR,
1216 # specific options here
1217 summary => {type => SCALAR|UNDEF,
1221 %append_action_options,
1224 croak "summary must be numeric or undef" if
1225 defined $param{summary} and not $param{summary} =~ /^\d+$/;
1227 __begin_control(%param,
1228 command => 'summary'
1230 my ($new_locks,$debug,$transcript) =
1231 @info{qw(new_locks debug transcript)};
1232 my @data = @{$info{data}};
1233 my @bugs = @{$info{bugs}};
1234 # figure out the log that we're going to use
1236 my $summary_msg = '';
1238 if (not defined $param{summary}) {
1240 print {$debug} "Removing summary fields\n";
1241 $action = 'Removed summary';
1245 my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
1246 if ($param{summary} == 0) {
1247 $log = $param{message};
1248 $summary_msg = @records + 1;
1251 if (($param{summary} - 1 ) > $#records) {
1252 die "Message number '$param{summary}' exceeds the maximum message '$#records'";
1254 my $record = $records[($param{summary} - 1 )];
1255 if ($record->{type} !~ /incoming-recv|recips/) {
1256 die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
1258 $summary_msg = $param{summary};
1259 $log = [$record->{text}];
1261 my $p_o = Debbugs::MIME::parse(join('',@{$log}));
1262 my $body = $p_o->{body};
1263 my $in_pseudoheaders = 0;
1265 # walk through body until we get non-blank lines
1266 for my $line (@{$body}) {
1267 if ($line =~ /^\s*$/) {
1268 if (length $paragraph) {
1269 if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
1275 $in_pseudoheaders = 0;
1278 # skip a paragraph if it looks like it's control or
1280 if ($line =~ m{^\s*(?:(?:Package|Source|Version)\:| #pseudo headers
1281 (?:package|(?:no|)owner|severity|tag|summary| #control
1282 reopen|close|(?:not|)(?:fixed|found)|clone|
1283 (?:force|)merge|user(?:category|tag|)
1286 if (not length $paragraph) {
1287 print {$debug} "Found control/pseudo-headers and skiping them\n";
1288 $in_pseudoheaders = 1;
1292 next if $in_pseudoheaders;
1293 $paragraph .= $line ." \n";
1295 print {$debug} "Summary is going to be '$paragraph'\n";
1296 $summary = $paragraph;
1297 $summary =~ s/[\n\r]/ /g;
1298 if (not length $summary) {
1299 die "Unable to find summary message to use";
1301 # trim off a trailing spaces
1302 $summary =~ s/\ *$//;
1304 for my $data (@data) {
1305 print {$debug} "Going to change summary\n";
1306 if (((not defined $summary or not length $summary) and
1307 (not defined $data->{summary} or not length $data->{summary})) or
1308 $summary eq $data->{summary}) {
1309 print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1310 unless __internal_request();
1313 if (length $summary) {
1314 if (length $data->{summary}) {
1315 $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1318 $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1321 my $old_data = dclone($data);
1322 $data->{summary} = $summary;
1323 append_action_to_log(bug => $data->{bug_num},
1324 command => 'summary',
1325 old_data => $old_data,
1328 __return_append_to_log_options(
1333 if not exists $param{append_log} or $param{append_log};
1334 writebug($data->{bug_num},$data);
1335 print {$transcript} "$action\n";
1337 __end_control(%info);
1343 =head1 OWNER FUNCTIONS
1349 transcript => $transcript,
1350 ($dl > 0 ? (debug => $transcript):()),
1351 requester => $header{from},
1352 request_addr => $controlrequestaddr,
1354 recipients => \%recipients,
1360 print {$transcript} "Failed to mark $ref as having an owner: $@";
1363 Handles all setting of the owner field; given an owner of undef or of
1364 no length, indicates that a bug is not owned by anyone.
1369 my %param = validate_with(params => \@_,
1370 spec => {bug => {type => SCALAR,
1373 owner => {type => SCALAR|UNDEF,
1376 %append_action_options,
1380 __begin_control(%param,
1383 my ($new_locks,$debug,$transcript) =
1384 @info{qw(new_locks debug transcript)};
1385 my @data = @{$info{data}};
1386 my @bugs = @{$info{bugs}};
1388 for my $data (@data) {
1389 print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
1390 print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
1391 if (not defined $param{owner} or not length $param{owner}) {
1392 if (not defined $data->{owner} or not length $data->{owner}) {
1393 print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
1394 unless __internal_request();
1398 $action = "Removed annotation that $config{bug} was owned by " .
1402 if ($data->{owner} eq $param{owner}) {
1403 print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
1406 if (length $data->{owner}) {
1407 $action = "Owner changed from $data->{owner} to $param{owner}.";
1410 $action = "Owner recorded as $param{owner}."
1413 my $old_data = dclone($data);
1414 $data->{owner} = $param{owner};
1415 append_action_to_log(bug => $data->{bug_num},
1418 old_data => $old_data,
1420 __return_append_to_log_options(
1425 if not exists $param{append_log} or $param{append_log};
1426 writebug($data->{bug_num},$data);
1427 print {$transcript} "$action\n";
1429 __end_control(%info);
1433 =head1 ARCHIVE FUNCTIONS
1440 bug_archive(bug => $bug_num,
1442 transcript => \$transcript,
1447 transcript("Unable to archive $bug_num\n");
1450 transcript($transcript);
1453 This routine archives a bug
1457 =item bug -- bug number
1459 =item check_archiveable -- check wether a bug is archiveable before
1460 archiving; defaults to 1
1462 =item archive_unarchived -- whether to archive bugs which have not
1463 previously been archived; defaults to 1. [Set to 0 when used from
1466 =item ignore_time -- whether to ignore time constraints when archiving
1467 a bug; defaults to 0.
1474 my %param = validate_with(params => \@_,
1475 spec => {bug => {type => SCALAR,
1478 check_archiveable => {type => BOOLEAN,
1481 archive_unarchived => {type => BOOLEAN,
1484 ignore_time => {type => BOOLEAN,
1488 %append_action_options,
1491 my %info = __begin_control(%param,
1492 command => 'archive',
1494 my ($new_locks,$debug,$transcript) = @info{qw(data debug transcript)};
1495 my @data = @{$info{data}};
1496 my @bugs = @{$info{bugs}};
1497 my $action = "$config{bug} archived.";
1498 if ($param{check_archiveable} and
1499 not bug_archiveable(bug=>$param{bug},
1500 ignore_time => $param{ignore_time},
1502 print {$transcript} "Bug $param{bug} cannot be archived\n";
1503 die "Bug $param{bug} cannot be archived";
1505 print {$debug} "$param{bug} considering\n";
1506 if (not $param{archive_unarchived} and
1507 not exists $data[0]{unarchived}
1509 print {$transcript} "$param{bug} has not been archived previously\n";
1510 die "$param{bug} has not been archived previously";
1512 add_recipients(recipients => $param{recipients},
1515 transcript => $transcript,
1517 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
1518 for my $bug (@bugs) {
1519 if ($param{check_archiveable}) {
1520 die "Bug $bug cannot be archived (but $param{bug} can?)"
1521 unless bug_archiveable(bug=>$bug,
1522 ignore_time => $param{ignore_time},
1526 # If we get here, we can archive/remove this bug
1527 print {$debug} "$param{bug} removing\n";
1528 for my $bug (@bugs) {
1529 #print "$param{bug} removing $bug\n" if $debug;
1530 my $dir = get_hashname($bug);
1531 # First indicate that this bug is being archived
1532 append_action_to_log(bug => $bug,
1534 command => 'archive',
1535 # we didn't actually change the data
1536 # when we archived, so we don't pass
1537 # a real new_data or old_data
1540 __return_append_to_log_options(
1545 if not exists $param{append_log} or $param{append_log};
1546 my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
1547 if ($config{save_old_bugs}) {
1548 mkpath("$config{spool_dir}/archive/$dir");
1549 foreach my $file (@files_to_remove) {
1550 link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
1551 copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
1552 # we need to bail out here if things have
1553 # gone horribly wrong to avoid removing a
1555 die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
1558 print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
1560 unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
1561 print {$transcript} "deleted $bug (from $param{bug})\n";
1563 bughook_archive(@bugs);
1564 __end_control(%info);
1567 =head2 bug_unarchive
1571 bug_unarchive(bug => $bug_num,
1573 transcript => \$transcript,
1578 transcript("Unable to archive bug: $bug_num");
1580 transcript($transcript);
1582 This routine unarchives a bug
1587 my %param = validate_with(params => \@_,
1588 spec => {bug => {type => SCALAR,
1592 %append_action_options,
1596 my %info = __begin_control(%param,
1598 command=>'unarchive');
1599 my ($new_locks,$debug,$transcript) =
1600 @info{qw(new_locks debug transcript)};
1601 my @data = @{$info{data}};
1602 my @bugs = @{$info{bugs}};
1603 my $action = "$config{bug} unarchived.";
1604 my @files_to_remove;
1605 for my $bug (@bugs) {
1606 print {$debug} "$param{bug} removing $bug\n";
1607 my $dir = get_hashname($bug);
1608 my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
1609 mkpath("archive/$dir");
1610 foreach my $file (@files_to_copy) {
1611 # die'ing here sucks
1612 link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
1613 copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
1614 die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
1616 push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
1617 print {$transcript} "Unarchived $config{bug} $bug\n";
1619 unlink(@files_to_remove) or die "Unable to unlink bugs";
1620 # Indicate that this bug has been archived previously
1621 for my $bug (@bugs) {
1622 my $newdata = readbug($bug);
1623 my $old_data = dclone($newdata);
1624 if (not defined $newdata) {
1625 print {$transcript} "$config{bug} $bug disappeared!\n";
1626 die "Bug $bug disappeared!";
1628 $newdata->{unarchived} = time;
1629 append_action_to_log(bug => $bug,
1631 command => 'unarchive',
1632 new_data => $newdata,
1633 old_data => $old_data,
1634 __return_append_to_log_options(
1639 if not exists $param{append_log} or $param{append_log};
1640 writebug($bug,$newdata);
1642 __end_control(%info);
1645 =head2 append_action_to_log
1647 append_action_to_log
1649 This should probably be moved to Debbugs::Log; have to think that out
1654 sub append_action_to_log{
1655 my %param = validate_with(params => \@_,
1656 spec => {bug => {type => SCALAR,
1659 new_data => {type => HASHREF,
1662 old_data => {type => HASHREF,
1665 command => {type => SCALAR,
1668 action => {type => SCALAR,
1670 requester => {type => SCALAR,
1673 request_addr => {type => SCALAR,
1676 location => {type => SCALAR,
1679 message => {type => SCALAR|ARRAYREF,
1682 desc => {type => SCALAR,
1685 get_lock => {type => BOOLEAN,
1689 # append_action_options here
1690 # because some of these
1691 # options aren't actually
1692 # optional, even though the
1693 # original function doesn't
1697 # Fix this to use $param{location}
1698 my $log_location = buglog($param{bug});
1699 die "Unable to find .log for $param{bug}"
1700 if not defined $log_location;
1701 if ($param{get_lock}) {
1702 filelock("lock/$param{bug}");
1704 my $log = IO::File->new(">>$log_location") or
1705 die "Unable to open $log_location for appending: $!";
1706 # determine difference between old and new
1708 if (exists $param{old_data} and exists $param{new_data}) {
1709 my $old_data = dclone($param{old_data});
1710 my $new_data = dclone($param{new_data});
1711 for my $key (keys %{$old_data}) {
1712 if (not exists $Debbugs::Status::fields{$key}) {
1713 delete $old_data->{$key};
1716 next unless exists $new_data->{$key};
1717 next unless defined $new_data->{$key};
1718 if (not defined $old_data->{$key}) {
1719 delete $old_data->{$key};
1722 if (ref($new_data->{$key}) and
1723 ref($old_data->{$key}) and
1724 ref($new_data->{$key}) eq ref($old_data->{$key})) {
1725 local $Storable::canonical = 1;
1726 # print STDERR Dumper($new_data,$old_data,$key);
1727 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
1728 delete $new_data->{$key};
1729 delete $old_data->{$key};
1732 elsif ($new_data->{$key} eq $old_data->{$key}) {
1733 delete $new_data->{$key};
1734 delete $old_data->{$key};
1737 for my $key (keys %{$new_data}) {
1738 if (not exists $Debbugs::Status::fields{$key}) {
1739 delete $new_data->{$key};
1742 next unless exists $old_data->{$key};
1743 next unless defined $old_data->{$key};
1744 if (not defined $new_data->{$key} or
1745 not exists $Debbugs::Status::fields{$key}) {
1746 delete $new_data->{$key};
1749 if (ref($new_data->{$key}) and
1750 ref($old_data->{$key}) and
1751 ref($new_data->{$key}) eq ref($old_data->{$key})) {
1752 local $Storable::canonical = 1;
1753 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
1754 delete $new_data->{$key};
1755 delete $old_data->{$key};
1758 elsif ($new_data->{$key} eq $old_data->{$key}) {
1759 delete $new_data->{$key};
1760 delete $old_data->{$key};
1763 $data_diff .= "<!-- new_data:\n";
1765 for my $key (keys %{$new_data}) {
1766 if (not exists $Debbugs::Status::fields{$key}) {
1767 warn "No such field $key";
1770 $nd{$key} = $new_data->{$key};
1771 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
1773 $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
1774 $data_diff .= "-->\n";
1775 $data_diff .= "<!-- old_data:\n";
1777 for my $key (keys %{$old_data}) {
1778 if (not exists $Debbugs::Status::fields{$key}) {
1779 warn "No such field $key";
1782 $od{$key} = $old_data->{$key};
1783 # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
1785 $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
1786 $data_diff .= "-->\n";
1788 my $msg = join('',"\6\n",
1789 (exists $param{command} ?
1790 "<!-- command:".html_escape($param{command})." -->\n":""
1792 (length $param{requester} ?
1793 "<!-- requester: ".html_escape($param{requester})." -->\n":""
1795 (length $param{request_addr} ?
1796 "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
1798 "<!-- time:".time()." -->\n",
1800 "<strong>".html_escape($param{action})."</strong>\n");
1801 if (length $param{requester}) {
1802 $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
1804 if (length $param{request_addr}) {
1805 $msg .= "to <code>".html_escape($param{request_addr})."</code>";
1807 if (length $param{desc}) {
1808 $msg .= ":<br>\n$param{desc}\n";
1814 if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
1815 $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
1816 or die "Unable to append to $log_location: $!";
1818 print {$log} $msg or die "Unable to append to $log_location: $!";
1819 close $log or die "Unable to close $log_location: $!";
1820 if ($param{get_lock}) {
1828 =head1 PRIVATE FUNCTIONS
1830 =head2 __handle_affected_packages
1832 __handle_affected_packages(affected_packages => {},
1840 sub __handle_affected_packages{
1841 my %param = validate_with(params => \@_,
1842 spec => {%common_options,
1843 data => {type => ARRAYREF|HASHREF
1848 for my $data (make_list($param{data})) {
1849 next unless exists $data->{package} and defined $data->{package};
1850 my @packages = split /\s*,\s*/,$data->{package};
1851 @{$param{affected_packages}}{@packages} = (1) x @packages;
1855 =head2 __handle_debug_transcript
1857 my ($debug,$transcript) = __handle_debug_transcript(%param);
1859 Returns a debug and transcript filehandle
1864 sub __handle_debug_transcript{
1865 my %param = validate_with(params => \@_,
1866 spec => {%common_options},
1869 my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
1870 my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
1871 return ($debug,$transcript);
1878 Produces a small bit of bug information to kick out to the transcript
1885 next unless defined $data and exists $data->{bug_num};
1886 $return .= "Bug #".($data->{bug_num}||'').
1887 ((defined $data->{done} and length $data->{done})?
1888 " {Done: $data->{done}}":''
1890 " [".($data->{package}||'(no package)'). "] ".
1891 ($data->{subject}||'(no subject)')."\n";
1897 =head2 __internal_request
1899 __internal_request()
1900 __internal_request($level)
1902 Returns true if the caller of the function calling __internal_request
1903 belongs to __PACKAGE__
1905 This allows us to be magical, and don't bother to print bug info if
1906 the second caller is from this package, amongst other things.
1908 An optional level is allowed, which increments the number of levels to
1909 check by the given value. [This is basically for use by internal
1910 functions like __begin_control which are always called by
1915 sub __internal_request{
1917 $l = 0 if not defined $l;
1918 if (defined +(caller(2+$l))[0] and +(caller(2+$l))[0] eq __PACKAGE__) {
1924 sub __return_append_to_log_options{
1926 my $action = $param{action} if exists $param{action};
1927 if (not exists $param{requester}) {
1928 $param{requester} = $config{control_internal_requester};
1930 if (not exists $param{request_addr}) {
1931 $param{request_addr} = $config{control_internal_request_addr};
1933 if (not exists $param{message}) {
1934 my $date = rfc822_date();
1935 $param{message} = fill_in_template(template => 'mail/fake_control_message',
1936 variables => {request_addr => $param{request_addr},
1937 requester => $param{requester},
1943 if (not defined $action) {
1944 carp "Undefined action!";
1945 $action = "unknown action";
1947 return (action => $action,
1948 (map {exists $append_action_options{$_}?($_,$param{$_}):()}
1953 =head2 __begin_control
1955 my %info = __begin_control(%param,
1957 command=>'unarchive');
1958 my ($new_locks,$debug,$transcript) = @info{qw(new_locksa debug transcript)};
1959 my @data = @{$info{data}};
1960 my @bugs = @{$info{bugs}};
1963 Starts the process of modifying a bug; handles all of the generic
1964 things that almost every control request needs
1966 Returns a hash containing
1970 =item new_locks -- number of new locks taken out by this call
1972 =item debug -- the debug file handle
1974 =item transcript -- the transcript file handle
1976 =item data -- an arrayref containing the data of the bugs
1977 corresponding to this request
1979 =item bugs -- an arrayref containing the bug numbers of the bugs
1980 corresponding to this request
1988 sub __begin_control {
1989 my %param = validate_with(params => \@_,
1990 spec => {bug => {type => SCALAR,
1993 archived => {type => BOOLEAN,
1996 command => {type => SCALAR,
2004 my ($debug,$transcript) = __handle_debug_transcript(@_);
2005 print {$debug} "$param{bug} considering\n";
2007 my $old_die = $SIG{__DIE__};
2008 $SIG{__DIE__} = *sig_die{CODE};
2010 ($new_locks, @data) =
2011 lock_read_all_merged_bugs($param{bug},
2012 ($param{archived}?'archive':()));
2013 $locks += $new_locks;
2015 die "Unable to read any bugs successfully.";
2018 # XXX check the limit at this point, and die if it is exceeded.
2019 # This is currently not done
2021 __handle_affected_packages(%param,data => \@data);
2022 print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2023 print {$debug} "$param{bug} read $locks locks\n";
2024 if (not @data or not defined $data[0]) {
2025 print {$transcript} "No bug found for $param{bug}\n";
2026 die "No bug found for $param{bug}";
2029 add_recipients(data => \@data,
2030 recipients => $param{recipients},
2031 (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2033 transcript => $transcript,
2036 print {$debug} "$param{bug} read done\n";
2037 my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2038 print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2039 return (data => \@data,
2041 old_die => $old_die,
2042 new_locks => $new_locks,
2044 transcript => $transcript,
2049 =head2 __end_control
2051 __end_control(%info);
2053 Handles tearing down from a control request
2059 if (exists $info{new_locks} and $info{new_locks} > 0) {
2060 print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2061 for (1..$info{new_locks}) {
2065 $SIG{__DIE__} = $info{old_die};
2066 if (exists $info{param}{bugs_affected}) {
2067 @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2069 add_recipients(recipients => $info{param}{recipients},
2070 (exists $info{param}{command}?(actions_taken => {$info{param}{command} => 1}):()),
2071 data => $info{data},
2072 debug => $info{debug},
2073 transcript => $info{transcript},
2075 __handle_affected_packages(%{$info{param}},data=>$info{data});
2083 We override die to specially handle unlocking files in the cases where
2084 we are called via eval. [If we're not called via eval, it doesn't
2090 #if ($^S) { # in eval
2092 for (1..$locks) { unfilelock(); }