+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Control;
-
-=head1 NAME
-
-Debbugs::Control -- Routines for modifying the state of bugs
-
-=head1 SYNOPSIS
-
-use Debbugs::Control;
-
-
-=head1 DESCRIPTION
-
-This module is an abstraction of a lot of functions which originally
-were only present in service.in, but as time has gone on needed to be
-called from elsewhere.
-
-All of the public functions take the following options:
-
-=over
-
-=item debug -- scalar reference to which debbuging information is
-appended
-
-=item transcript -- scalar reference to which transcript information
-is appended
-
-=item affected_bugs -- hashref which is updated with bugs affected by
-this function
-
-
-=back
-
-Functions which should (probably) append to the .log file take the
-following options:
-
-=over
-
-=item requester -- Email address of the individual who requested the change
-
-=item request_addr -- Address to which the request was sent
-
-=item request_nn -- Name of queue file which caused this request
-
-=item request_msgid -- Message id of message which caused this request
-
-=item location -- Optional location; currently ignored but may be
-supported in the future for updating archived bugs upon archival
-
-=item message -- The original message which caused the action to be taken
-
-=item append_log -- Whether or not to append information to the log.
-
-=back
-
-B<append_log> (for most functions) is a special option. When set to
-false, no appending to the log is done at all. When it is not present,
-the above information is faked, and appended to the log file. When it
-is true, the above options must be present, and their values are used.
-
-
-=head1 GENERAL FUNCTIONS
-
-=cut
-
-use warnings;
-use strict;
-use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use Exporter qw(import);
-
-BEGIN{
- $VERSION = 1.00;
- $DEBUG = 0 unless defined $DEBUG;
-
- @EXPORT = ();
- %EXPORT_TAGS = (done => [qw(set_done)],
- submitter => [qw(set_submitter)],
- severity => [qw(set_severity)],
- affects => [qw(affects)],
- summary => [qw(summary)],
- outlook => [qw(outlook)],
- owner => [qw(owner)],
- title => [qw(set_title)],
- forward => [qw(set_forwarded)],
- found => [qw(set_found set_fixed)],
- fixed => [qw(set_found set_fixed)],
- package => [qw(set_package)],
- block => [qw(set_blocks)],
- merge => [qw(set_merged)],
- tag => [qw(set_tag)],
- clone => [qw(clone_bug)],
- archive => [qw(bug_archive bug_unarchive),
- ],
- limit => [qw(check_limit)],
- log => [qw(append_action_to_log),
- ],
- );
- @EXPORT_OK = ();
- Exporter::export_ok_tags(keys %EXPORT_TAGS);
- $EXPORT_TAGS{all} = [@EXPORT_OK];
-}
-
-use Debbugs::Config qw(:config);
-use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions);
-use Debbugs::UTF8;
-use Debbugs::Status qw(bug_archiveable :read :hook writebug new_bug splitpackages split_status_fields get_bug_status);
-use Debbugs::CGI qw(html_escape);
-use Debbugs::Log qw(:misc :write);
-use Debbugs::Recipients qw(:add);
-use Debbugs::Packages qw(:versions :mapping);
-
-use Data::Dumper qw();
-use Params::Validate qw(validate_with :types);
-use File::Path qw(mkpath);
-use File::Copy qw(copy);
-use IO::File;
-
-use Debbugs::Text qw(:templates);
-
-use Debbugs::Mail qw(rfc822_date send_mail_message default_headers encode_headers);
-use Debbugs::MIME qw(create_mime_message);
-
-use Mail::RFC822::Address qw();
-
-use POSIX qw(strftime);
-
-use Storable qw(dclone nfreeze);
-use List::AllUtils qw(first max);
-use Encode qw(encode_utf8);
-
-use Carp;
-
-# These are a set of options which are common to all of these functions
-
-my %common_options = (debug => {type => SCALARREF|HANDLE,
- optional => 1,
- },
- transcript => {type => SCALARREF|HANDLE,
- optional => 1,
- },
- affected_bugs => {type => HASHREF,
- optional => 1,
- },
- affected_packages => {type => HASHREF,
- optional => 1,
- },
- recipients => {type => HASHREF,
- default => {},
- },
- limit => {type => HASHREF,
- default => {},
- },
- show_bug_info => {type => BOOLEAN,
- default => 1,
- },
- request_subject => {type => SCALAR,
- default => 'Unknown Subject',
- },
- request_msgid => {type => SCALAR,
- default => '',
- },
- request_nn => {type => SCALAR,
- optional => 1,
- },
- request_replyto => {type => SCALAR,
- optional => 1,
- },
- locks => {type => HASHREF,
- optional => 1,
- },
- );
-
-
-my %append_action_options =
- (action => {type => SCALAR,
- optional => 1,
- },
- requester => {type => SCALAR,
- optional => 1,
- },
- request_addr => {type => SCALAR,
- optional => 1,
- },
- location => {type => SCALAR,
- optional => 1,
- },
- message => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- append_log => {type => BOOLEAN,
- optional => 1,
- depends => [qw(requester request_addr),
- qw(message),
- ],
- },
- # locks is both an append_action option, and a common option;
- # it's ok for it to be in both places.
- locks => {type => HASHREF,
- optional => 1,
- },
- );
-
-our $locks = 0;
-
-
-# this is just a generic stub for Debbugs::Control functions.
-#
-# =head2 set_foo
-#
-# eval {
-# set_foo(bug => $ref,
-# transcript => $transcript,
-# ($dl > 0 ? (debug => $transcript):()),
-# requester => $header{from},
-# request_addr => $controlrequestaddr,
-# message => \@log,
-# affected_packages => \%affected_packages,
-# recipients => \%recipients,
-# summary => undef,
-# );
-# };
-# if ($@) {
-# $errors++;
-# print {$transcript} "Failed to set foo $ref bar: $@";
-# }
-#
-# Foo frobinates
-#
-# =cut
-#
-# sub set_foo {
-# my %param = validate_with(params => \@_,
-# spec => {bug => {type => SCALAR,
-# regex => qr/^\d+$/,
-# },
-# # specific options here
-# %common_options,
-# %append_action_options,
-# },
-# );
-# my %info =
-# __begin_control(%param,
-# command => 'foo'
-# );
-# my ($debug,$transcript) =
-# @info{qw(debug transcript)};
-# my @data = @{$info{data}};
-# my @bugs = @{$info{bugs}};
-#
-# my $action = '';
-# for my $data (@data) {
-# append_action_to_log(bug => $data->{bug_num},
-# get_lock => 0,
-# __return_append_to_log_options(
-# %param,
-# action => $action,
-# ),
-# )
-# if not exists $param{append_log} or $param{append_log};
-# writebug($data->{bug_num},$data);
-# print {$transcript} "$action\n";
-# }
-# __end_control(%info);
-# }
-
-
-=head2 set_blocks
-
- eval {
- set_block(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- block => [],
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set blockers of $ref: $@";
- }
-
-Alters the set of bugs that block this bug from being fixed
-
-This requires altering both this bug (and those it's merged with) as
-well as the bugs that block this bug from being fixed (and those that
-it's merged with)
-
-=over
-
-=item block -- scalar or arrayref of blocking bugs to set, add or remove
-
-=item add -- if true, add blocking bugs
-
-=item remove -- if true, remove blocking bugs
-
-=back
-
-=cut
-
-sub set_blocks {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- block => {type => SCALAR|ARRAYREF,
- default => [],
- },
- add => {type => BOOLEAN,
- default => 0,
- },
- remove => {type => BOOLEAN,
- default => 0,
- },
- %common_options,
- %append_action_options,
- },
- );
- if ($param{add} and $param{remove}) {
- croak "It's nonsensical to add and remove the same blocking bugs";
- }
- if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
- croak "Invalid blocking bug(s):".
- join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
- }
- my $mode = 'set';
- if ($param{add}) {
- $mode = 'add';
- }
- elsif ($param{remove}) {
- $mode = 'remove';
- }
-
- my %info =
- __begin_control(%param,
- command => 'blocks'
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
-
-
- # The first bit of this code is ugly, and should be cleaned up.
- # Its purpose is to populate %removed_blockers and %add_blockers
- # with all of the bugs that should be added or removed as blockers
- # of all of the bugs which are merged with $param{bug}
- my %ok_blockers;
- my %bad_blockers;
- for my $blocker (make_list($param{block})) {
- next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
- my $data = read_bug(bug=>$blocker,
- );
- if (defined $data and not $data->{archived}) {
- $data = split_status_fields($data);
- $ok_blockers{$blocker} = 1;
- my @merged_bugs;
- push @merged_bugs, make_list($data->{mergedwith});
- @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
- }
- else {
- $bad_blockers{$blocker} = 1;
- }
- }
-
- # throw an error if we are setting the blockers and there is a bad
- # blocker
- if (keys %bad_blockers and $mode eq 'set') {
- __end_control(%info);
- croak "Unknown/archived blocking bug(s):".join(', ',keys %bad_blockers).
- keys %ok_blockers?'':" and no good blocking bug(s)";
- }
- # if there are no ok blockers and we are not setting the blockers,
- # there's an error.
- if (not keys %ok_blockers and $mode ne 'set') {
- print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
- if (keys %bad_blockers) {
- __end_control(%info);
- croak "Unknown/archived blocking bug(s):".join(', ',keys %bad_blockers);
- }
- __end_control(%info);
- return;
- }
-
- my @change_blockers = keys %ok_blockers;
-
- my %removed_blockers;
- my %added_blockers;
- my $action = '';
- my @blockers = map {split ' ', $_->{blockedby}} @data;
- my %blockers;
- @blockers{@blockers} = (1) x @blockers;
-
- # it is nonsensical for a bug to block itself (or a merged
- # partner); We currently don't allow removal because we'd possibly
- # deadlock
-
- my %bugs;
- @bugs{@bugs} = (1) x @bugs;
- for my $blocker (@change_blockers) {
- if ($bugs{$blocker}) {
- __end_control(%info);
- croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
- }
- }
- @blockers = keys %blockers;
- if ($param{add}) {
- %removed_blockers = ();
- for my $blocker (@change_blockers) {
- next if exists $blockers{$blocker};
- $blockers{$blocker} = 1;
- $added_blockers{$blocker} = 1;
- }
- }
- elsif ($param{remove}) {
- %added_blockers = ();
- for my $blocker (@change_blockers) {
- next if exists $removed_blockers{$blocker};
- delete $blockers{$blocker};
- $removed_blockers{$blocker} = 1;
- }
- }
- else {
- @removed_blockers{@blockers} = (1) x @blockers;
- %blockers = ();
- for my $blocker (@change_blockers) {
- next if exists $blockers{$blocker};
- $blockers{$blocker} = 1;
- if (exists $removed_blockers{$blocker}) {
- delete $removed_blockers{$blocker};
- }
- else {
- $added_blockers{$blocker} = 1;
- }
- }
- }
- for my $data (@data) {
- my $old_data = dclone($data);
- # remove blockers and/or add new ones as appropriate
- if ($data->{blockedby} eq '') {
- print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n";
- } else {
- print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n";
- }
- if ($data->{blocks} eq '') {
- print {$transcript} "$data->{bug_num} was not blocking any bugs.\n";
- } else {
- print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n";
- }
- my @changed;
- push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
- push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers;
- $action = ucfirst(join ('; ',@changed)) if @changed;
- if (not @changed) {
- print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n";
- next;
- }
- $data->{blockedby} = join(' ',keys %blockers);
- append_action_to_log(bug => $data->{bug_num},
- command => 'block',
- old_data => $old_data,
- new_data => $data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- # we do this bit below to avoid code duplication
- my %mungable_blocks;
- $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
- $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
- my $new_locks = 0;
- for my $add_remove (keys %mungable_blocks) {
- my %munge_blockers;
- for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
- next if $munge_blockers{$blocker};
- my ($temp_locks, @blocking_data) =
- lock_read_all_merged_bugs(bug => $blocker,
- ($param{archived}?(location => 'archive'):()),
- exists $param{locks}?(locks => $param{locks}):(),
- );
- $locks+= $temp_locks;
- $new_locks+=$temp_locks;
- if (not @blocking_data) {
- for (1..$new_locks) {
- unfilelock(exists $param{locks}?$param{locks}:());
- $locks--;
- }
- die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
- }
- for (map {$_->{bug_num}} @blocking_data) {
- $munge_blockers{$_} = 1;
- }
- for my $data (@blocking_data) {
- my $old_data = dclone($data);
- my %blocks;
- my @blocks = split ' ', $data->{blocks};
- @blocks{@blocks} = (1) x @blocks;
- @blocks = ();
- for my $bug (@bugs) {
- if ($add_remove eq 'remove') {
- next unless exists $blocks{$bug};
- delete $blocks{$bug};
- }
- else {
- next if exists $blocks{$bug};
- $blocks{$bug} = 1;
- }
- push @blocks, $bug;
- }
- $data->{blocks} = join(' ',sort keys %blocks);
- my $action = ($add_remove eq 'add'?'Added':'Removed').
- " indication that bug $data->{bug_num} blocks ".
- join(',',@blocks);
- append_action_to_log(bug => $data->{bug_num},
- command => 'block',
- old_data => $old_data,
- new_data => $data,
- get_lock => 0,
- __return_append_to_log_options(%param,
- action => $action
- )
- );
- writebug($data->{bug_num},$data);
- }
- __handle_affected_packages(%param,data=>\@blocking_data);
- add_recipients(recipients => $param{recipients},
- actions_taken => {blocks => 1},
- data => \@blocking_data,
- debug => $debug,
- transcript => $transcript,
- );
-
- for (1..$new_locks) {
- unfilelock(exists $param{locks}?$param{locks}:());
- $locks--;
- }
- }
- }
- __end_control(%info);
-}
-
-
-
-=head2 set_tag
-
- eval {
- set_tag(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- tag => [],
- add => 1,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set tag on $ref: $@";
- }
-
-
-Sets, adds, or removes the specified tags on a bug
-
-=over
-
-=item tag -- scalar or arrayref of tags to set, add or remove
-
-=item add -- if true, add tags
-
-=item remove -- if true, remove tags
-
-=item warn_on_bad_tags -- if true (the default) warn if bad tags are
-passed.
-
-=back
-
-=cut
-
-sub set_tag {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- tag => {type => SCALAR|ARRAYREF,
- default => [],
- },
- add => {type => BOOLEAN,
- default => 0,
- },
- remove => {type => BOOLEAN,
- default => 0,
- },
- warn_on_bad_tags => {type => BOOLEAN,
- default => 1,
- },
- %common_options,
- %append_action_options,
- },
- );
- if ($param{add} and $param{remove}) {
- croak "It's nonsensical to add and remove the same tags";
- }
-
- my %info =
- __begin_control(%param,
- command => 'tag'
- );
- my $transcript = $info{transcript};
- my @data = @{$info{data}};
- my @tags = make_list($param{tag});
- if (not @tags and ($param{remove} or $param{add})) {
- if ($param{remove}) {
- print {$transcript} "Requested to remove no tags; doing nothing.\n";
- }
- else {
- print {$transcript} "Requested to add no tags; doing nothing.\n";
- }
- __end_control(%info);
- return;
- }
- # first things first, make the versions fully qualified source
- # versions
- for my $data (@data) {
- my $action = 'Did not alter tags';
- my %tag_added = ();
- my %tag_removed = ();
- my @old_tags = split /\,?\s+/, $data->{keywords};
- my %tags;
- @tags{@old_tags} = (1) x @old_tags;
- my $old_data = dclone($data);
- if (not $param{add} and not $param{remove}) {
- $tag_removed{$_} = 1 for @old_tags;
- %tags = ();
- }
- my @bad_tags = ();
- for my $tag (@tags) {
- if (not $param{remove} and
- not defined first {$_ eq $tag} @{$config{tags}}) {
- push @bad_tags, $tag;
- next;
- }
- if ($param{add}) {
- if (not exists $tags{$tag}) {
- $tags{$tag} = 1;
- $tag_added{$tag} = 1;
- }
- }
- elsif ($param{remove}) {
- if (exists $tags{$tag}) {
- delete $tags{$tag};
- $tag_removed{$tag} = 1;
- }
- }
- else {
- if (exists $tag_removed{$tag}) {
- delete $tag_removed{$tag};
- }
- else {
- $tag_added{$tag} = 1;
- }
- $tags{$tag} = 1;
- }
- }
- if (@bad_tags and $param{warn_on_bad_tags}) {
- print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
- print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
- }
- $data->{keywords} = join(' ',keys %tags);
-
- my @changed;
- push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
- push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
- $action = ucfirst(join ('; ',@changed)) if @changed;
- if (not @changed) {
- print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n";
- next;
- }
- $action .= '.';
- append_action_to_log(bug => $data->{bug_num},
- get_lock => 0,
- command => 'tag',
- old_data => $old_data,
- new_data => $data,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
-}
-
-
-
-=head2 set_severity
-
- eval {
- set_severity(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- severity => 'normal',
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set the severity of bug $ref: $@";
- }
-
-Sets the severity of a bug. If severity is not passed, is undefined,
-or has zero length, sets the severity to the default severity.
-
-=cut
-
-sub set_severity {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- severity => {type => SCALAR|UNDEF,
- default => $config{default_severity},
- },
- %common_options,
- %append_action_options,
- },
- );
- if (not defined $param{severity} or
- not length $param{severity}
- ) {
- $param{severity} = $config{default_severity};
- }
-
- # check validity of new severity
- if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
- die "Severity '$param{severity}' is not a valid severity level";
- }
- my %info =
- __begin_control(%param,
- command => 'severity'
- );
- my $transcript = $info{transcript};
- my @data = @{$info{data}};
-
- my $action = '';
- for my $data (@data) {
- if (not defined $data->{severity}) {
- $data->{severity} = $param{severity};
- $action = "Severity set to '$param{severity}'";
- }
- else {
- if ($data->{severity} eq '') {
- $data->{severity} = $config{default_severity};
- }
- if ($data->{severity} eq $param{severity}) {
- print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
- next;
- }
- $action = "Severity set to '$param{severity}' from '$data->{severity}'";
- $data->{severity} = $param{severity};
- }
- append_action_to_log(bug => $data->{bug_num},
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
-}
-
-
-=head2 set_done
-
- eval {
- set_done(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set foo $ref bar: $@";
- }
-
-Foo frobinates
-
-=cut
-
-sub set_done {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- reopen => {type => BOOLEAN,
- default => 0,
- },
- submitter => {type => SCALAR,
- optional => 1,
- },
- clear_fixed => {type => BOOLEAN,
- default => 1,
- },
- notify_submitter => {type => BOOLEAN,
- default => 1,
- },
- original_report => {type => SCALARREF,
- optional => 1,
- },
- done => {type => SCALAR|UNDEF,
- optional => 1,
- },
- %common_options,
- %append_action_options,
- },
- );
-
- if (exists $param{submitter} and
- not Mail::RFC822::Address::valid($param{submitter})) {
- die "New submitter address '$param{submitter}' is not a valid e-mail address";
- }
- if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address
- $param{done} = $param{requester};
- }
- if (exists $param{done} and
- (not defined $param{done} or
- not length $param{done})) {
- delete $param{done};
- $param{reopen} = 1;
- }
-
- my %info =
- __begin_control(%param,
- command => $param{reopen}?'reopen':'done',
- );
- my $transcript = $info{transcript};
- my @data = @{$info{data}};
- my $action ='';
-
- if ($param{reopen}) {
- # avoid warning multiple times if there are fixed versions
- my $warn_fixed = 1;
- for my $data (@data) {
- if (not exists $data->{done} or
- not defined $data->{done} or
- not length $data->{done}) {
- print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
- __end_control(%info);
- return;
- }
- if (@{$data->{fixed_versions}} and $warn_fixed) {
- print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
- print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n";
- $warn_fixed = 0;
- }
- }
- $action = "Bug reopened";
- for my $data (@data) {
- my $old_data = dclone($data);
- $data->{done} = '';
- append_action_to_log(bug => $data->{bug_num},
- command => 'done',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- }
- print {$transcript} "$action\n";
- __end_control(%info);
- if (exists $param{submitter}) {
- set_submitter(bug => $param{bug},
- submitter => $param{submitter},
- hash_slice(%param,
- keys %common_options,
- keys %append_action_options)
- );
- }
- # clear the fixed revisions
- if ($param{clear_fixed}) {
- set_fixed(fixed => [],
- bug => $param{bug},
- reopen => 0,
- hash_slice(%param,
- keys %common_options,
- keys %append_action_options),
- );
- }
- }
- else {
- my %submitter_notified;
- my $orig_report_set = 0;
- for my $data (@data) {
- if (exists $data->{done} and
- defined $data->{done} and
- length $data->{done}) {
- print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
- __end_control(%info);
- return;
- }
- }
- for my $data (@data) {
- my $old_data = dclone($data);
- my $hash = get_hashname($data->{bug_num});
- my $report_fh = IO::File->new("$config{spool_dir}/db-h/$hash/$data->{bug_num}.report",'r') or
- die "Unable to open original report $config{spool_dir}/db-h/$hash/$data->{bug_num}.report for reading: $!";
- my $orig_report;
- {
- local $/;
- $orig_report= <$report_fh>;
- }
- close $report_fh;
- if (not $orig_report_set and defined $orig_report and
- length $orig_report and
- exists $param{original_report}){
- ${$param{original_report}} = $orig_report;
- $orig_report_set = 1;
- }
-
- $action = "Marked $config{bug} as done";
-
- # set done to the requester
- $data->{done} = exists $param{done}?$param{done}:$param{requester};
- append_action_to_log(bug => $data->{bug_num},
- command => 'done',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- # get the original report
- if ($param{notify_submitter}) {
- my $submitter_message;
- if(not exists $submitter_notified{$data->{originator}}) {
- $submitter_message =
- create_mime_message([default_headers(queue_file => $param{request_nn},
- data => $data,
- msgid => $param{request_msgid},
- msgtype => 'notifdone',
- pr_msg => 'they-closed',
- headers =>
- [To => $data->{submitter},
- Subject => "$config{ubug}#$data->{bug_num} ".
- "closed by $param{requester} ".(defined $param{request_subject}?"($param{request_subject})":""),
- ],
- )
- ],
- __message_body_template('mail/process_your_bug_done',
- {data => $data,
- replyto => (exists $param{request_replyto} ?
- $param{request_replyto} :
- $param{requester} || 'Unknown'),
- markedby => $param{requester},
- subject => $param{request_subject},
- messageid => $param{request_msgid},
- config => \%config,
- }),
- [join('',make_list($param{message})),$orig_report]
- );
- send_mail_message(message => $submitter_message,
- recipients => $old_data->{submitter},
- );
- $submitter_notified{$data->{originator}} = $submitter_message;
- }
- else {
- $submitter_message = $submitter_notified{$data->{originator}};
- }
- append_action_to_log(bug => $data->{bug_num},
- action => "Notification sent",
- requester => '',
- request_addr => $data->{originator},
- desc => "$config{bug} acknowledged by developer.",
- recips => [$data->{originator}],
- message => $submitter_message,
- get_lock => 0,
- );
- }
- }
- __end_control(%info);
- if (exists $param{fixed}) {
- set_fixed(fixed => $param{fixed},
- bug => $param{bug},
- reopen => 0,
- hash_slice(%param,
- keys %common_options,
- keys %append_action_options
- ),
- );
- }
- }
-}
-
-
-=head2 set_submitter
-
- eval {
- set_submitter(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- submitter => $new_submitter,
- notify_submitter => 1,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
- }
-
-Sets the submitter of a bug. If notify_submitter is true (the
-default), notifies the old submitter of a bug on changes
-
-=cut
-
-sub set_submitter {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- submitter => {type => SCALAR,
- },
- notify_submitter => {type => BOOLEAN,
- default => 1,
- },
- %common_options,
- %append_action_options,
- },
- );
- if (not Mail::RFC822::Address::valid($param{submitter})) {
- die "New submitter address $param{submitter} is not a valid e-mail address";
- }
- my %info =
- __begin_control(%param,
- command => 'submitter'
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my $action = '';
- # here we only concern ourselves with the first of the merged bugs
- for my $data ($data[0]) {
- my $notify_old_submitter = 0;
- my $old_data = dclone($data);
- print {$debug} "Going to change bug submitter\n";
- if (((not defined $param{submitter} or not length $param{submitter}) and
- (not defined $data->{originator} or not length $data->{originator})) or
- (defined $param{submitter} and defined $data->{originator} and
- $param{submitter} eq $data->{originator})) {
- print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n";
- next;
- }
- else {
- if (defined $data->{originator} and length($data->{originator})) {
- $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'.";
- $notify_old_submitter = 1;
- }
- else {
- $action= "Set $config{bug} submitter to '$param{submitter}'.";
- }
- $data->{originator} = $param{submitter};
- }
- append_action_to_log(bug => $data->{bug_num},
- command => 'submitter',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- # notify old submitter
- if ($notify_old_submitter and $param{notify_submitter}) {
- send_mail_message(message =>
- create_mime_message([default_headers(queue_file => $param{request_nn},
- data => $data,
- msgid => $param{request_msgid},
- msgtype => 'ack',
- pr_msg => 'submitter-changed',
- headers =>
- [To => $old_data->{submitter},
- Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
- ],
- )
- ],
- __message_body_template('mail/submitter_changed',
- {old_data => $old_data,
- data => $data,
- replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
- config => \%config,
- })
- ),
- recipients => $old_data->{submitter},
- );
- }
- }
- __end_control(%info);
-}
-
-
-
-=head2 set_forwarded
-
- eval {
- set_forwarded(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- forwarded => $forward_to,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
- }
-
-Sets the location to which a bug is forwarded. Given an undef
-forwarded, unsets forwarded.
-
-
-=cut
-
-sub set_forwarded {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- forwarded => {type => SCALAR|UNDEF,
- },
- %common_options,
- %append_action_options,
- },
- );
- if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
- die "Non-printable characters are not allowed in the forwarded field";
- }
- $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
- my %info =
- __begin_control(%param,
- command => 'forwarded'
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my $action = '';
- for my $data (@data) {
- my $old_data = dclone($data);
- print {$debug} "Going to change bug forwarded\n";
- if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
- (not defined $param{forwarded} and
- defined $data->{forwarded} and not length $data->{forwarded})) {
- print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n";
- next;
- }
- else {
- if (not defined $param{forwarded}) {
- $action= "Unset $config{bug} forwarded-to-address";
- }
- elsif (defined $data->{forwarded} and length($data->{forwarded})) {
- $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'.";
- }
- else {
- $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
- }
- $data->{forwarded} = $param{forwarded};
- }
- append_action_to_log(bug => $data->{bug_num},
- command => 'forwarded',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
-}
-
-
-
-
-=head2 set_title
-
- eval {
- set_title(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- title => $new_title,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set the title of $ref: $@";
- }
-
-Sets the title of a specific bug
-
-
-=cut
-
-sub set_title {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- title => {type => SCALAR,
- },
- %common_options,
- %append_action_options,
- },
- );
- if ($param{title} =~ /[^[:print:]]/) {
- die "Non-printable characters are not allowed in bug titles";
- }
-
- my %info = __begin_control(%param,
- command => 'title',
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my $action = '';
- for my $data (@data) {
- my $old_data = dclone($data);
- print {$debug} "Going to change bug title\n";
- if (defined $data->{subject} and length($data->{subject}) and
- $data->{subject} eq $param{title}) {
- print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n";
- next;
- }
- else {
- if (defined $data->{subject} and length($data->{subject})) {
- $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'.";
- } else {
- $action= "Set $config{bug} title to '$param{title}'.";
- }
- $data->{subject} = $param{title};
- }
- append_action_to_log(bug => $data->{bug_num},
- command => 'title',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
-}
-
-
-=head2 set_package
-
- eval {
- set_package(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- package => $new_package,
- is_source => 0,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to assign or reassign $ref to a package: $@";
- }
-
-Indicates that a bug is in a particular package. If is_source is true,
-indicates that the package is a source package. [Internally, this
-causes src: to be prepended to the package name.]
-
-The default for is_source is 0. As a special case, if the package
-starts with 'src:', it is assumed to be a source package and is_source
-is overridden.
-
-The package option must match the package_name_re regex.
-
-=cut
-
-sub set_package {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- package => {type => SCALAR|ARRAYREF,
- },
- is_source => {type => BOOLEAN,
- default => 0,
- },
- %common_options,
- %append_action_options,
- },
- );
- my @new_packages = map {splitpackages($_)} make_list($param{package});
- if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
- croak "Invalid package name '".
- join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
- "'";
- }
- my %info = __begin_control(%param,
- command => 'package',
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- # clean up the new package
- my $new_package =
- join(',',
- map {my $temp = $_;
- ($temp =~ s/^src:// or
- $param{is_source}) ? 'src:'.$temp:$temp;
- } @new_packages);
-
- my $action = '';
- my $package_reassigned = 0;
- for my $data (@data) {
- my $old_data = dclone($data);
- print {$debug} "Going to change assigned package\n";
- if (defined $data->{package} and length($data->{package}) and
- $data->{package} eq $new_package) {
- print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n";
- next;
- }
- else {
- if (defined $data->{package} and length($data->{package})) {
- $package_reassigned = 1;
- $action= "$config{bug} reassigned from package '$data->{package}'".
- " to '$new_package'.";
- } else {
- $action= "$config{bug} assigned to package '$new_package'.";
- }
- $data->{package} = $new_package;
- }
- append_action_to_log(bug => $data->{bug_num},
- command => 'package',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
- # Only clear the fixed/found versions if the package has been
- # reassigned
- if ($package_reassigned) {
- my @params_for_found_fixed =
- map {exists $param{$_}?($_,$param{$_}):()}
- ('bug',
- keys %common_options,
- keys %append_action_options,
- );
- set_found(found => [],
- @params_for_found_fixed,
- );
- set_fixed(fixed => [],
- @params_for_found_fixed,
- );
- }
-}
-
-=head2 set_found
-
- eval {
- set_found(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- found => [],
- add => 1,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set found on $ref: $@";
- }
-
-
-Sets, adds, or removes the specified found versions of a package
-
-If the version list is empty, and the bug is currently not "done",
-causes the done field to be cleared.
-
-If any of the versions added to found are greater than any version in
-which the bug is fixed (or when the bug is found and there are no
-fixed versions) the done field is cleared.
-
-=cut
-
-sub set_found {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- found => {type => SCALAR|ARRAYREF,
- default => [],
- },
- add => {type => BOOLEAN,
- default => 0,
- },
- remove => {type => BOOLEAN,
- default => 0,
- },
- %common_options,
- %append_action_options,
- },
- );
- if ($param{add} and $param{remove}) {
- croak "It's nonsensical to add and remove the same versions";
- }
-
- my %info =
- __begin_control(%param,
- command => 'found'
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my %versions;
- for my $version (make_list($param{found})) {
- next unless defined $version;
- $versions{$version} =
- [make_source_versions(package => [splitpackages($data[0]{package})],
- warnings => $transcript,
- debug => $debug,
- guess_source => 0,
- versions => $version,
- )
- ];
- # This is really ugly, but it's what we have to do
- if (not @{$versions{$version}}) {
- print {$transcript} "Unable to make a source version for version '$version'\n";
- }
- }
- if (not keys %versions and ($param{remove} or $param{add})) {
- if ($param{remove}) {
- print {$transcript} "Requested to remove no versions; doing nothing.\n";
- }
- else {
- print {$transcript} "Requested to add no versions; doing nothing.\n";
- }
- __end_control(%info);
- return;
- }
- # first things first, make the versions fully qualified source
- # versions
- for my $data (@data) {
- # The 'done' field gets a bit weird with version tracking,
- # because a bug may be closed by multiple people in different
- # branches. Until we have something more flexible, we set it
- # every time a bug is fixed, and clear it when a bug is found
- # in a version greater than any version in which the bug is
- # fixed or when a bug is found and there is no fixed version
- my $action = 'Did not alter found versions';
- my %found_added = ();
- my %found_removed = ();
- my %fixed_removed = ();
- my $reopened = 0;
- my $old_data = dclone($data);
- if (not $param{add} and not $param{remove}) {
- $found_removed{$_} = 1 for @{$data->{found_versions}};
- $data->{found_versions} = [];
- }
- my %found_versions;
- @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
- my %fixed_versions;
- @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
- for my $version (keys %versions) {
- if ($param{add}) {
- my @svers = @{$versions{$version}};
- if (not @svers) {
- @svers = $version;
- }
- elsif (not grep {$version eq $_} @svers) {
- # The $version was not equal to one of the source
- # versions, so it's probably unqualified (or just
- # wrong). Delete it, and use the source versions
- # instead.
- if (exists $found_versions{$version}) {
- delete $found_versions{$version};
- $found_removed{$version} = 1;
- }
- }
- for my $sver (@svers) {
- if (not exists $found_versions{$sver}) {
- $found_versions{$sver} = 1;
- $found_added{$sver} = 1;
- }
- # if the found we are adding matches any fixed
- # versions, remove them
- my @temp = grep m{(^|/)\Q$sver\E$}, keys %fixed_versions;
- delete $fixed_versions{$_} for @temp;
- $fixed_removed{$_} = 1 for @temp;
- }
-
- # We only care about reopening the bug if the bug is
- # not done
- if (defined $data->{done} and length $data->{done}) {
- my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
- @svers);
- # determine if we need to reopen
- my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
- keys %fixed_versions);
- if (not @fixed_order or
- (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
- $reopened = 1;
- $data->{done} = '';
- }
- }
- }
- elsif ($param{remove}) {
- # in the case of removal, we only concern ourself with
- # the version passed, not the source version it maps
- # to
- my @temp = grep m{(?:^|/)\Q$version\E$}, keys %found_versions;
- delete $found_versions{$_} for @temp;
- $found_removed{$_} = 1 for @temp;
- }
- else {
- # set the keys to exactly these values
- my @svers = @{$versions{$version}};
- if (not @svers) {
- @svers = $version;
- }
- for my $sver (@svers) {
- if (not exists $found_versions{$sver}) {
- $found_versions{$sver} = 1;
- if (exists $found_removed{$sver}) {
- delete $found_removed{$sver};
- }
- else {
- $found_added{$sver} = 1;
- }
- }
- }
- }
- }
-
- $data->{found_versions} = [keys %found_versions];
- $data->{fixed_versions} = [keys %fixed_versions];
-
- my @changed;
- push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
- push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
-# push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
- push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
- $action = ucfirst(join ('; ',@changed)) if @changed;
- if ($reopened) {
- $action .= " and reopened"
- }
- if (not $reopened and not @changed) {
- print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n";
- next;
- }
- $action .= '.';
- append_action_to_log(bug => $data->{bug_num},
- get_lock => 0,
- command => 'found',
- old_data => $old_data,
- new_data => $data,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
-}
-
-=head2 set_fixed
-
- eval {
- set_fixed(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- fixed => [],
- add => 1,
- reopen => 0,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set fixed on $ref: $@";
- }
-
-
-Sets, adds, or removes the specified fixed versions of a package
-
-If the fixed versions are empty (or end up being empty after this
-call) or the greatest fixed version is less than the greatest found
-version and the reopen option is true, the bug is reopened.
-
-This function is also called by the reopen function, which causes all
-of the fixed versions to be cleared.
-
-=cut
-
-sub set_fixed {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- fixed => {type => SCALAR|ARRAYREF,
- default => [],
- },
- add => {type => BOOLEAN,
- default => 0,
- },
- remove => {type => BOOLEAN,
- default => 0,
- },
- reopen => {type => BOOLEAN,
- default => 0,
- },
- %common_options,
- %append_action_options,
- },
- );
- if ($param{add} and $param{remove}) {
- croak "It's nonsensical to add and remove the same versions";
- }
- my %info =
- __begin_control(%param,
- command => 'fixed'
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my %versions;
- for my $version (make_list($param{fixed})) {
- next unless defined $version;
- $versions{$version} =
- [make_source_versions(package => [splitpackages($data[0]{package})],
- warnings => $transcript,
- debug => $debug,
- guess_source => 0,
- versions => $version,
- )
- ];
- # This is really ugly, but it's what we have to do
- if (not @{$versions{$version}}) {
- print {$transcript} "Unable to make a source version for version '$version'\n";
- }
- }
- if (not keys %versions and ($param{remove} or $param{add})) {
- if ($param{remove}) {
- print {$transcript} "Requested to remove no versions; doing nothing.\n";
- }
- else {
- print {$transcript} "Requested to add no versions; doing nothing.\n";
- }
- __end_control(%info);
- return;
- }
- # first things first, make the versions fully qualified source
- # versions
- for my $data (@data) {
- my $old_data = dclone($data);
- # The 'done' field gets a bit weird with version tracking,
- # because a bug may be closed by multiple people in different
- # branches. Until we have something more flexible, we set it
- # every time a bug is fixed, and clear it when a bug is found
- # in a version greater than any version in which the bug is
- # fixed or when a bug is found and there is no fixed version
- my $action = 'Did not alter fixed versions';
- my %found_added = ();
- my %found_removed = ();
- my %fixed_added = ();
- my %fixed_removed = ();
- my $reopened = 0;
- if (not $param{add} and not $param{remove}) {
- $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
- $data->{fixed_versions} = [];
- }
- my %found_versions;
- @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
- my %fixed_versions;
- @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
- for my $version (keys %versions) {
- if ($param{add}) {
- my @svers = @{$versions{$version}};
- if (not @svers) {
- @svers = $version;
- }
- else {
- if (exists $fixed_versions{$version}) {
- $fixed_removed{$version} = 1;
- delete $fixed_versions{$version};
- }
- }
- for my $sver (@svers) {
- if (not exists $fixed_versions{$sver}) {
- $fixed_versions{$sver} = 1;
- $fixed_added{$sver} = 1;
- }
- }
- }
- elsif ($param{remove}) {
- # in the case of removal, we only concern ourself with
- # the version passed, not the source version it maps
- # to
- my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
- delete $fixed_versions{$_} for @temp;
- $fixed_removed{$_} = 1 for @temp;
- }
- else {
- # set the keys to exactly these values
- my @svers = @{$versions{$version}};
- if (not @svers) {
- @svers = $version;
- }
- for my $sver (@svers) {
- if (not exists $fixed_versions{$sver}) {
- $fixed_versions{$sver} = 1;
- if (exists $fixed_removed{$sver}) {
- delete $fixed_removed{$sver};
- }
- else {
- $fixed_added{$sver} = 1;
- }
- }
- }
- }
- }
-
- $data->{found_versions} = [keys %found_versions];
- $data->{fixed_versions} = [keys %fixed_versions];
-
- # If we're supposed to consider reopening, reopen if the
- # fixed versions are empty or the greatest found version
- # is greater than the greatest fixed version
- if ($param{reopen} and defined $data->{done}
- and length $data->{done}) {
- my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
- map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
- # determine if we need to reopen
- my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
- map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
- if (not @fixed_order or
- (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
- $reopened = 1;
- $data->{done} = '';
- }
- }
-
- my @changed;
- push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
- push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
- push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
- push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
- $action = ucfirst(join ('; ',@changed)) if @changed;
- if ($reopened) {
- $action .= " and reopened"
- }
- if (not $reopened and not @changed) {
- print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n";
- next;
- }
- $action .= '.';
- append_action_to_log(bug => $data->{bug_num},
- command => 'fixed',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
-}
-
-
-=head2 set_merged
-
- eval {
- set_merged(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- merge_with => 12345,
- add => 1,
- force => 1,
- allow_reassign => 1,
- reassign_same_source_only => 1,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to set merged on $ref: $@";
- }
-
-
-Sets, adds, or removes the specified merged bugs of a bug
-
-By default, requires
-
-=cut
-
-sub set_merged {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- merge_with => {type => ARRAYREF|SCALAR,
- optional => 1,
- },
- remove => {type => BOOLEAN,
- default => 0,
- },
- force => {type => BOOLEAN,
- default => 0,
- },
- masterbug => {type => BOOLEAN,
- default => 0,
- },
- allow_reassign => {type => BOOLEAN,
- default => 0,
- },
- reassign_different_sources => {type => BOOLEAN,
- default => 1,
- },
- %common_options,
- %append_action_options,
- },
- );
- my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
- my %merging;
- @merging{@merging} = (1) x @merging;
- if (grep {$_ !~ /^\d+$/} @merging) {
- croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
- }
- $param{locks} = {} if not exists $param{locks};
- my %info =
- __begin_control(%param,
- command => 'merge'
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- if (not @merging and exists $param{merge_with}) {
- print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
- __end_control(%info);
- return;
- }
- my @data = @{$info{data}};
- my %data;
- my %merged_bugs;
- for my $data (@data) {
- $data{$data->{bug_num}} = $data;
- my @merged_bugs = split / /, $data->{mergedwith};
- @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
- }
- # handle unmerging
- my $new_locks = 0;
- if (not exists $param{merge_with}) {
- delete $merged_bugs{$param{bug}};
- if (not keys %merged_bugs) {
- print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
- __end_control(%info);
- return;
- }
- my $action = "Disconnected #$param{bug} from all other report(s).";
- for my $data (@data) {
- my $old_data = dclone($data);
- if ($data->{bug_num} == $param{bug}) {
- $data->{mergedwith} = '';
- }
- else {
- $data->{mergedwith} =
- join(' ',
- sort {$a <=> $b}
- grep {$_ != $data->{bug_num}}
- keys %merged_bugs);
- }
- append_action_to_log(bug => $data->{bug_num},
- command => 'merge',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(%param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- }
- print {$transcript} "$action\n";
- __end_control(%info);
- return;
- }
- # lock and load all of the bugs we need
- my ($data,$n_locks) =
- __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
- data => \@data,
- locks => $param{locks},
- debug => $debug,
- );
- $new_locks += $n_locks;
- %data = %{$data};
- @data = values %data;
- if (not check_limit(data => [@data],
- exists $param{limit}?(limit => $param{limit}):(),
- transcript => $transcript,
- )) {
- die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
- }
- for my $data (@data) {
- $data{$data->{bug_num}} = $data;
- $merged_bugs{$data->{bug_num}} = 1;
- my @merged_bugs = split / /, $data->{mergedwith};
- @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
- if (exists $param{affected_bugs}) {
- $param{affected_bugs}{$data->{bug_num}} = 1;
- }
- }
- __handle_affected_packages(%param,data => [@data]);
- my %bug_info_shown; # which bugs have had information shown
- $bug_info_shown{$param{bug}} = 1;
- add_recipients(data => [@data],
- recipients => $param{recipients},
- (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
- debug => $debug,
- (__internal_request()?(transcript => $transcript):()),
- );
-
- # Figure out what the ideal state is for the bug,
- my ($merge_status,$bugs_to_merge) =
- __calculate_merge_status(\@data,\%data,$param{bug});
- # find out if we actually have any bugs to merge
- if (not $bugs_to_merge) {
- print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
- for (1..$new_locks) {
- unfilelock($param{locks});
- $locks--;
- }
- __end_control(%info);
- return;
- }
- # see what changes need to be made to merge the bugs
- # check to make sure that the set of changes we need to make is allowed
- my ($disallowed_changes,$changes) =
- __calculate_merge_changes(\@data,$merge_status,\%param);
- # at this point, stop if there are disallowed changes, otherwise
- # make the allowed changes, and then reread the bugs in question
- # to get the new data, then recaculate the merges; repeat
- # reloading and recalculating until we try too many times or there
- # are no changes to make.
-
- my $attempts = 0;
- # we will allow at most 4 times through this; more than 1
- # shouldn't really happen.
- my %bug_changed;
- while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
- if ($attempts > 1) {
- print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
- }
- if (@{$disallowed_changes}) {
- # figure out the problems
- print {$transcript} "Unable to merge bugs because:\n";
- for my $change (@{$disallowed_changes}) {
- print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
- }
- if ($attempts > 0) {
- __end_control(%info);
- croak "Some bugs were altered while attempting to merge";
- }
- else {
- __end_control(%info);
- croak "Did not alter merged bugs";
- }
- }
- my @bugs_to_change = keys %{$changes};
- for my $change_bug (@bugs_to_change) {
- next unless exists $changes->{$change_bug};
- $bug_changed{$change_bug}++;
- print {$transcript} __bug_info($data{$change_bug}) if
- $param{show_bug_info} and not __internal_request(1);
- $bug_info_shown{$change_bug} = 1;
- __allow_relocking($param{locks},[keys %data]);
- eval {
- for my $change (@{$changes->{$change_bug}}) {
- if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
- my %target_blockedby;
- @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
- my %unhandled_targets = %target_blockedby;
- for my $key (split / /,$change->{orig_value}) {
- delete $unhandled_targets{$key};
- next if exists $target_blockedby{$key};
- set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
- block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
- remove => 1,
- hash_slice(%param,
- keys %common_options,
- keys %append_action_options),
- );
- }
- for my $key (keys %unhandled_targets) {
- set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug},
- block => $change->{field} eq 'blocks' ? $change->{bug} : $key,
- add => 1,
- hash_slice(%param,
- keys %common_options,
- keys %append_action_options),
- );
- }
- }
- else {
- $change->{function}->(bug => $change->{bug},
- $change->{key}, $change->{func_value},
- exists $change->{options}?@{$change->{options}}:(),
- hash_slice(%param,
- keys %common_options,
- keys %append_action_options),
- );
- }
- }
- };
- if ($@) {
- __disallow_relocking($param{locks});
- __end_control(%info);
- croak "Failure while trying to adjust bugs, please report this as a bug: $@";
- }
- __disallow_relocking($param{locks});
- my ($data,$n_locks) =
- __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
- data => \@data,
- locks => $param{locks},
- debug => $debug,
- reload_all => 1,
- );
- $new_locks += $n_locks;
- $locks += $n_locks;
- %data = %{$data};
- @data = values %data;
- ($merge_status,$bugs_to_merge) =
- __calculate_merge_status(\@data,\%data,$param{bug},$merge_status);
- ($disallowed_changes,$changes) =
- __calculate_merge_changes(\@data,$merge_status,\%param);
- $attempts = max(values %bug_changed);
- }
- }
- if ($param{show_bug_info} and not __internal_request(1)) {
- for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
- next if $bug_info_shown{$data->{bug_num}};
- print {$transcript} __bug_info($data);
- }
- }
- if (keys %{$changes} or @{$disallowed_changes}) {
- print {$transcript} "After four attempts, the following changes were unable to be made:\n";
- for (1..$new_locks) {
- unfilelock($param{locks});
- $locks--;
- }
- __end_control(%info);
- for my $change ((map {@{$_}} values %{$changes}), @{$disallowed_changes}) {
- print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
- }
- die "Unable to modify bugs so they could be merged";
- return;
- }
-
- # finally, we can merge the bugs
- my $action = "Merged ".join(' ',sort { $a <=> $b } keys %merged_bugs);
- for my $data (@data) {
- my $old_data = dclone($data);
- $data->{mergedwith} =
- join(' ',
- sort { $a <=> $b }
- grep {$_ != $data->{bug_num}}
- keys %merged_bugs);
- append_action_to_log(bug => $data->{bug_num},
- command => 'merge',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(%param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- }
- print {$transcript} "$action\n";
- # unlock the extra locks that we got earlier
- for (1..$new_locks) {
- unfilelock($param{locks});
- $locks--;
- }
- __end_control(%info);
-}
-
-sub __allow_relocking{
- my ($locks,$bugs) = @_;
-
- my @locks = (@{$bugs},'merge');
- for my $lock (@locks) {
- my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}};
- next unless @lockfiles;
- $locks->{relockable}{$lockfiles[0]} = 0;
- }
-}
-
-sub __disallow_relocking{
- my ($locks) = @_;
- delete $locks->{relockable};
-}
-
-sub __lock_and_load_merged_bugs{
- my %param =
- validate_with(params => \@_,
- spec =>
- {bugs_to_load => {type => ARRAYREF,
- default => sub {[]},
- },
- data => {type => HASHREF|ARRAYREF,
- },
- locks => {type => HASHREF,
- default => sub {{};},
- },
- reload_all => {type => BOOLEAN,
- default => 0,
- },
- debug => {type => HANDLE,
- },
- },
- );
- my %data;
- my $new_locks = 0;
- if (ref($param{data}) eq 'ARRAY') {
- for my $data (@{$param{data}}) {
- $data{$data->{bug_num}} = dclone($data);
- }
- }
- else {
- %data = %{dclone($param{data})};
- }
- my @bugs_to_load = @{$param{bugs_to_load}};
- if ($param{reload_all}) {
- push @bugs_to_load, keys %data;
- }
- my %temp;
- @temp{@bugs_to_load} = (1) x @bugs_to_load;
- @bugs_to_load = keys %temp;
- my %loaded_this_time;
- my $bug_to_load;
- while ($bug_to_load = shift @bugs_to_load) {
- if (not $param{reload_all}) {
- next if exists $data{$bug_to_load};
- }
- else {
- next if $loaded_this_time{$bug_to_load};
- }
- my $lock_bug = 1;
- if ($param{reload_all}) {
- if (exists $data{$bug_to_load}) {
- $lock_bug = 0;
- }
- }
- my $data =
- read_bug(bug => $bug_to_load,
- lock => $lock_bug,
- locks => $param{locks},
- ) or
- die "Unable to load bug $bug_to_load";
- print {$param{debug}} "read bug $bug_to_load\n";
- $data{$data->{bug_num}} = $data;
- $new_locks += $lock_bug;
- $loaded_this_time{$data->{bug_num}} = 1;
- push @bugs_to_load,
- grep {not exists $data{$_}}
- split / /,$data->{mergedwith};
- }
- return (\%data,$new_locks);
-}
-
-
-sub __calculate_merge_status{
- my ($data_a,$data_h,$master_bug,$merge_status) = @_;
- my %merge_status = %{$merge_status // {}};
- my %merged_bugs;
- my $bugs_to_merge = 0;
- for my $data (@{$data_a}) {
- # check to see if this bug is unmerged in the set
- if (not length $data->{mergedwith} or
- grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
- $merged_bugs{$data->{bug_num}} = 1;
- $bugs_to_merge = 1;
- }
- }
- for my $data (@{$data_a}) {
- # the master_bug is the bug that every other bug is made to
- # look like. However, if merge is set, tags, fixed and found
- # are merged.
- if ($data->{bug_num} == $master_bug) {
- for (qw(package forwarded severity done owner summary outlook affects)) {
- $merge_status{$_} = $data->{$_}
- }
- # bugs which are in the newly merged set and are also
- # blocks/blockedby must be removed before merging
- for (qw(blocks blockedby)) {
- $merge_status{$_} =
- join(' ',grep {not exists $merged_bugs{$_}}
- split / /,$data->{$_});
- }
- }
- if (defined $merge_status) {
- next unless $data->{bug_num} == $master_bug;
- }
- $merge_status{tag} = {} if not exists $merge_status{tag};
- for my $tag (split /\s+/, $data->{keywords}) {
- $merge_status{tag}{$tag} = 1;
- }
- $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
- for (qw(fixed found)) {
- @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
- }
- }
- # if there is a non-source qualified version with a corresponding
- # source qualified version, we only want to merge the source
- # qualified version(s)
- for (qw(fixed found)) {
- my @unqualified_versions = grep {m{/}?0:1} keys %{$merge_status{"${_}_versions"}};
- for my $unqualified_version (@unqualified_versions) {
- if (grep {m{/\Q$unqualified_version\E}} keys %{$merge_status{"${_}_versions"}}) {
- delete $merge_status{"${_}_versions"}{$unqualified_version};
- }
- }
- }
- return (\%merge_status,$bugs_to_merge);
-}
-
-
-
-sub __calculate_merge_changes{
- my ($datas,$merge_status,$param) = @_;
- my %changes;
- my @disallowed_changes;
- for my $data (@{$datas}) {
- # things that can be forced
- #
- # * func is the function to set the new value
- #
- # * key is the key of the function to set the value,
-
- # * modify_value is a function which is called to modify the new
- # value so that the function will accept it
-
- # * options is an ARRAYREF of options to pass to the function
-
- # * allowed is a BOOLEAN which controls whether this setting
- # is allowed to be different by default.
- my %force_functions =
- (forwarded => {func => \&set_forwarded,
- key => 'forwarded',
- options => [],
- },
- severity => {func => \&set_severity,
- key => 'severity',
- options => [],
- },
- blocks => {func => \&set_blocks,
- modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
- key => 'block',
- options => [],
- },
- blockedby => {func => \&set_blocks,
- modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
- key => 'block',
- options => [],
- },
- done => {func => \&set_done,
- key => 'done',
- options => [],
- },
- owner => {func => \&owner,
- key => 'owner',
- options => [],
- },
- summary => {func => \&summary,
- key => 'summary',
- options => [],
- },
- outlook => {func => \&outlook,
- key => 'outlook',
- options => [],
- },
- affects => {func => \&affects,
- key => 'package',
- options => [],
- },
- package => {func => \&set_package,
- key => 'package',
- options => [],
- },
- keywords => {func => \&set_tag,
- key => 'tag',
- modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
- allowed => 1,
- },
- fixed_versions => {func => \&set_fixed,
- key => 'fixed',
- modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
- allowed => 1,
- },
- found_versions => {func => \&set_found,
- key => 'found',
- modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
- allowed => 1,
- },
- );
- for my $field (qw(forwarded severity blocks blockedby done owner summary outlook affects package fixed_versions found_versions keywords)) {
- # if the ideal bug already has the field set properly, we
- # continue on.
- if ($field eq 'keywords'){
- next if join(' ',sort split /\s+/,$data->{keywords}) eq
- join(' ',sort keys %{$merge_status->{tag}});
- }
- elsif ($field =~ /^(?:fixed|found)_versions$/) {
- next if join(' ', sort @{$data->{$field}}) eq
- join(' ',sort keys %{$merge_status->{$field}});
- }
- elsif ($field eq 'done') {
- # for done, we only care if the bug is done or not
- # done, not the value it's set to.
- if (defined $merge_status->{$field} and length $merge_status->{$field} and
- defined $data->{$field} and length $data->{$field}) {
- next;
- }
- elsif ((not defined $merge_status->{$field} or not length $merge_status->{$field}) and
- (not defined $data->{$field} or not length $data->{$field})
- ) {
- next;
- }
- }
- elsif ($merge_status->{$field} eq $data->{$field}) {
- next;
- }
- my $change =
- {field => $field,
- bug => $data->{bug_num},
- orig_value => $data->{$field},
- func_value =>
- (exists $force_functions{$field}{modify_value} ?
- $force_functions{$field}{modify_value}->($merge_status->{$field}):
- $merge_status->{$field}),
- value => $merge_status->{$field},
- function => $force_functions{$field}{func},
- key => $force_functions{$field}{key},
- options => $force_functions{$field}{options},
- allowed => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0,
- };
- $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
- $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
- if ($param->{force} or $change->{allowed}) {
- if ($field ne 'package' or $change->{allowed}) {
- push @{$changes{$data->{bug_num}}},$change;
- next;
- }
- if ($param->{allow_reassign}) {
- if ($param->{reassign_different_sources}) {
- push @{$changes{$data->{bug_num}}},$change;
- next;
- }
- # allow reassigning if binary_to_source returns at
- # least one of the same source packages
- my @merge_status_source =
- binary_to_source(package => $merge_status->{package},
- source_only => 1,
- );
- my @other_bug_source =
- binary_to_source(package => $data->{package},
- source_only => 1,
- );
- my %merge_status_sources;
- @merge_status_sources{@merge_status_source} =
- (1) x @merge_status_source;
- if (grep {$merge_status_sources{$_}} @other_bug_source) {
- push @{$changes{$data->{bug_num}}},$change;
- next;
- }
- }
- }
- push @disallowed_changes,$change;
- }
- # blocks and blocked by are weird; we have to go through and
- # set blocks to the other half of the merged bugs
- }
- return (\@disallowed_changes,\%changes);
-}
-
-=head2 affects
-
- eval {
- affects(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- packages => undef,
- add => 1,
- remove => 0,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to mark $ref as affecting $packages: $@";
- }
-
-This marks a bug as affecting packages which the bug is not actually
-in. This should only be used in cases where fixing the bug instantly
-resolves the problem in the other packages.
-
-By default, the packages are set to the list of packages passed.
-However, if you pass add => 1 or remove => 1, the list of packages
-passed are added or removed from the affects list, respectively.
-
-=cut
-
-sub affects {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- package => {type => SCALAR|ARRAYREF|UNDEF,
- default => [],
- },
- add => {type => BOOLEAN,
- default => 0,
- },
- remove => {type => BOOLEAN,
- default => 0,
- },
- %common_options,
- %append_action_options,
- },
- );
- if ($param{add} and $param{remove}) {
- croak "Asking to both add and remove affects is nonsensical";
- }
- if (not defined $param{package}) {
- $param{package} = [];
- }
- my %info =
- __begin_control(%param,
- command => 'affects'
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my $action = '';
- for my $data (@data) {
- $action = '';
- print {$debug} "Going to change affects\n";
- my @packages = splitpackages($data->{affects});
- my %packages;
- @packages{@packages} = (1) x @packages;
- if ($param{add}) {
- my @added = ();
- for my $package (make_list($param{package})) {
- next unless defined $package and length $package;
- if (not $packages{$package}) {
- $packages{$package} = 1;
- push @added,$package;
- }
- }
- if (@added) {
- $action = "Added indication that $data->{bug_num} affects ".
- english_join(\@added);
- }
- }
- elsif ($param{remove}) {
- my @removed = ();
- for my $package (make_list($param{package})) {
- if ($packages{$package}) {
- next unless defined $package and length $package;
- delete $packages{$package};
- push @removed,$package;
- }
- }
- $action = "Removed indication that $data->{bug_num} affects " .
- english_join(\@removed);
- }
- else {
- my %added_packages = ();
- my %removed_packages = %packages;
- %packages = ();
- for my $package (make_list($param{package})) {
- next unless defined $package and length $package;
- $packages{$package} = 1;
- delete $removed_packages{$package};
- $added_packages{$package} = 1;
- }
- if (keys %removed_packages) {
- $action = "Removed indication that $data->{bug_num} affects ".
- english_join([keys %removed_packages]);
- $action .= "\n" if keys %added_packages;
- }
- if (keys %added_packages) {
- $action .= "Added indication that $data->{bug_num} affects " .
- english_join([keys %added_packages]);
- }
- }
- if (not length $action) {
- print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n";
- next;
- }
- my $old_data = dclone($data);
- $data->{affects} = join(',',keys %packages);
- append_action_to_log(bug => $data->{bug_num},
- get_lock => 0,
- command => 'affects',
- new_data => $data,
- old_data => $old_data,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
-}
-
-
-=head1 SUMMARY FUNCTIONS
-
-=head2 summary
-
- eval {
- summary(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- summary => undef,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to mark $ref with summary foo: $@";
- }
-
-Handles all setting of summary fields
-
-If summary is undef, unsets the summary
-
-If summary is 0 or -1, sets the summary to the first paragraph contained in
-the message passed.
-
-If summary is a positive integer, sets the summary to the message specified.
-
-Otherwise, sets summary to the value passed.
-
-=cut
-
-
-sub summary {
- # outlook and summary are exactly the same, basically
- return _summary('summary',@_);
-}
-
-=head1 OUTLOOK FUNCTIONS
-
-=head2 outlook
-
- eval {
- outlook(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- outlook => undef,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to mark $ref with outlook foo: $@";
- }
-
-Handles all setting of outlook fields
-
-If outlook is undef, unsets the outlook
-
-If outlook is 0, sets the outlook to the first paragraph contained in
-the message passed.
-
-If outlook is a positive integer, sets the outlook to the message specified.
-
-Otherwise, sets outlook to the value passed.
-
-=cut
-
-
-sub outlook {
- return _summary('outlook',@_);
-}
-
-sub _summary {
- my ($cmd,@params) = @_;
- my %param = validate_with(params => \@params,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- # specific options here
- $cmd , {type => SCALAR|UNDEF,
- default => 0,
- },
- %common_options,
- %append_action_options,
- },
- );
- my %info =
- __begin_control(%param,
- command => $cmd,
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- # figure out the log that we're going to use
- my $summary = '';
- my $summary_msg = '';
- my $action = '';
- if (not defined $param{$cmd}) {
- # do nothing
- print {$debug} "Removing $cmd fields\n";
- $action = "Removed $cmd";
- }
- elsif ($param{$cmd} =~ /^-?\d+$/) {
- my $log = [];
- my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
- if ($param{$cmd} == 0 or $param{$cmd} == -1) {
- $log = $param{message};
- $summary_msg = @records + 1;
- }
- else {
- if (($param{$cmd} - 1 ) > $#records) {
- die "Message number '$param{$cmd}' exceeds the maximum message '$#records'";
- }
- my $record = $records[($param{$cmd} - 1 )];
- if ($record->{type} !~ /incoming-recv|recips/) {
- die "Message number '$param{$cmd}' is a invalid message type '$record->{type}'";
- }
- $summary_msg = $param{$cmd};
- $log = [$record->{text}];
- }
- my $p_o = Debbugs::MIME::parse(join('',@{$log}));
- my $body = $p_o->{body};
- my $in_pseudoheaders = 0;
- my $paragraph = '';
- # walk through body until we get non-blank lines
- for my $line (@{$body}) {
- if ($line =~ /^\s*$/) {
- if (length $paragraph) {
- if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
- $paragraph = '';
- next;
- }
- last;
- }
- $in_pseudoheaders = 0;
- next;
- }
- # skip a paragraph if it looks like it's control or
- # pseudo-headers
- if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity|Control)\:\s+\S}xi or #pseudo headers
- $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
- \#|reopen|close|(?:not|)(?:fixed|found)|clone|
- debug|(?:not|)forwarded|priority|
- (?:un|)block|limit|(?:un|)archive|
- reassign|retitle|affects|package|
- outlook|
- (?:un|force|)merge|user(?:category|tags?|)
- )\s+\S}xis) {
- if (not length $paragraph) {
- print {$debug} "Found control/pseudo-headers and skiping them\n";
- $in_pseudoheaders = 1;
- next;
- }
- }
- next if $in_pseudoheaders;
- $paragraph .= $line ." \n";
- }
- print {$debug} ucfirst($cmd)." is going to be '$paragraph'\n";
- $summary = $paragraph;
- $summary =~ s/[\n\r]/ /g;
- if (not length $summary) {
- die "Unable to find $cmd message to use";
- }
- # trim off a trailing spaces
- $summary =~ s/\ *$//;
- }
- else {
- $summary = $param{$cmd};
- }
- for my $data (@data) {
- print {$debug} "Going to change $cmd\n";
- if (((not defined $summary or not length $summary) and
- (not defined $data->{$cmd} or not length $data->{$cmd})) or
- $summary eq $data->{$cmd}) {
- print {$transcript} "Ignoring request to change the $cmd of bug $param{bug} to the same value\n";
- next;
- }
- if (length $summary) {
- if (length $data->{$cmd}) {
- $action = ucfirst($cmd)." replaced with message bug $param{bug} message $summary_msg";
- }
- else {
- $action = ucfirst($cmd)." recorded from message bug $param{bug} message $summary_msg";
- }
- }
- my $old_data = dclone($data);
- $data->{$cmd} = $summary;
- append_action_to_log(bug => $data->{bug_num},
- command => $cmd,
- old_data => $old_data,
- new_data => $data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
-}
-
-
-
-=head2 clone_bug
-
- eval {
- clone_bug(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- affected_packages => \%affected_packages,
- recipients => \%recipients,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to clone bug $ref bar: $@";
- }
-
-Clones the given bug.
-
-We currently don't support cloning merged bugs, but this could be
-handled by internally unmerging, cloning, then remerging the bugs.
-
-=cut
-
-sub clone_bug {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- new_bugs => {type => ARRAYREF,
- },
- new_clones => {type => HASHREF,
- default => {},
- },
- %common_options,
- %append_action_options,
- },
- );
- my %info =
- __begin_control(%param,
- command => 'clone'
- );
- my $transcript = $info{transcript};
- my @data = @{$info{data}};
-
- my $action = '';
- for my $data (@data) {
- if (length($data->{mergedwith})) {
- die "Bug is marked as being merged with others. Use an existing clone.\n";
- }
- }
- if (@data != 1) {
- die "Not exactly one bug‽ This shouldn't happen.";
- }
- my $data = $data[0];
- my %clones;
- for my $newclone_id (@{$param{new_bugs}}) {
- my $new_bug_num = new_bug(copy => $data->{bug_num});
- $param{new_clones}{$newclone_id} = $new_bug_num;
- $clones{$newclone_id} = $new_bug_num;
- }
- my @new_bugs = sort values %clones;
- my @collapsed_ids;
- for my $new_bug (@new_bugs) {
- # no collapsed ids or the higher collapsed id is not one less
- # than the next highest new bug
- if (not @collapsed_ids or
- $collapsed_ids[-1][1]+1 != $new_bug) {
- push @collapsed_ids,[$new_bug,$new_bug];
- }
- else {
- $collapsed_ids[-1][1] = $new_bug;
- }
- }
- my @collapsed;
- for my $ci (@collapsed_ids) {
- if ($ci->[0] == $ci->[1]) {
- push @collapsed,$ci->[0];
- }
- else {
- push @collapsed,$ci->[0].'-'.$ci->[1]
- }
- }
- my $collapsed_str = english_join(\@collapsed);
- $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
- for my $new_bug (@new_bugs) {
- append_action_to_log(bug => $new_bug,
- get_lock => 1,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- }
- append_action_to_log(bug => $data->{bug_num},
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- __end_control(%info);
- # bugs that this bug is blocking are also blocked by the new clone(s)
- for my $bug (split ' ', $data->{blocks}) {
- for my $new_bug (@new_bugs) {
- set_blocks(bug => $bug,
- block => $new_bug,
- add => 1,
- hash_slice(%param,
- keys %common_options,
- keys %append_action_options),
- );
- }
- }
- # bugs that are blocking this bug are also blocking the new clone(s)
- for my $bug (split ' ', $data->{blockedby}) {
- for my $new_bug (@new_bugs) {
- set_blocks(bug => $new_bug,
- block => $bug,
- add => 1,
- hash_slice(%param,
- keys %common_options,
- keys %append_action_options),
- );
- }
- }
-}
-
-
-
-=head1 OWNER FUNCTIONS
-
-=head2 owner
-
- eval {
- owner(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- recipients => \%recipients,
- owner => undef,
- );
- };
- if ($@) {
- $errors++;
- print {$transcript} "Failed to mark $ref as having an owner: $@";
- }
-
-Handles all setting of the owner field; given an owner of undef or of
-no length, indicates that a bug is not owned by anyone.
-
-=cut
-
-sub owner {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- owner => {type => SCALAR|UNDEF,
- },
- %common_options,
- %append_action_options,
- },
- );
- my %info =
- __begin_control(%param,
- command => 'owner',
- );
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my $action = '';
- for my $data (@data) {
- print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
- print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
- if (not defined $param{owner} or not length $param{owner}) {
- if (not defined $data->{owner} or not length $data->{owner}) {
- print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n";
- next;
- }
- $param{owner} = '';
- $action = "Removed annotation that $config{bug} was owned by " .
- "$data->{owner}.";
- }
- else {
- if ($data->{owner} eq $param{owner}) {
- print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
- next;
- }
- if (length $data->{owner}) {
- $action = "Owner changed from $data->{owner} to $param{owner}.";
- }
- else {
- $action = "Owner recorded as $param{owner}."
- }
- }
- my $old_data = dclone($data);
- $data->{owner} = $param{owner};
- append_action_to_log(bug => $data->{bug_num},
- command => 'owner',
- new_data => $data,
- old_data => $old_data,
- get_lock => 0,
- __return_append_to_log_options(
- %param,
- action => $action,
- ),
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($data->{bug_num},$data);
- print {$transcript} "$action\n";
- }
- __end_control(%info);
-}
-
-
-=head1 ARCHIVE FUNCTIONS
-
-
-=head2 bug_archive
-
- my $error = '';
- eval {
- bug_archive(bug => $bug_num,
- debug => \$debug,
- transcript => \$transcript,
- );
- };
- if ($@) {
- $errors++;
- transcript("Unable to archive $bug_num\n");
- warn $@;
- }
- transcript($transcript);
-
-
-This routine archives a bug
-
-=over
-
-=item bug -- bug number
-
-=item check_archiveable -- check wether a bug is archiveable before
-archiving; defaults to 1
-
-=item archive_unarchived -- whether to archive bugs which have not
-previously been archived; defaults to 1. [Set to 0 when used from
-control@]
-
-=item ignore_time -- whether to ignore time constraints when archiving
-a bug; defaults to 0.
-
-=back
-
-=cut
-
-sub bug_archive {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- check_archiveable => {type => BOOLEAN,
- default => 1,
- },
- archive_unarchived => {type => BOOLEAN,
- default => 1,
- },
- ignore_time => {type => BOOLEAN,
- default => 0,
- },
- %common_options,
- %append_action_options,
- },
- );
- my %info = __begin_control(%param,
- command => 'archive',
- );
- my ($debug,$transcript) = @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
- my $action = "$config{bug} archived.";
- if ($param{check_archiveable} and
- not bug_archiveable(bug=>$param{bug},
- ignore_time => $param{ignore_time},
- )) {
- print {$transcript} "Bug $param{bug} cannot be archived\n";
- die "Bug $param{bug} cannot be archived";
- }
- if (not $param{archive_unarchived} and
- not exists $data[0]{unarchived}
- ) {
- print {$transcript} "$param{bug} has not been archived previously\n";
- die "$param{bug} has not been archived previously";
- }
- add_recipients(recipients => $param{recipients},
- data => \@data,
- debug => $debug,
- transcript => $transcript,
- );
- print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
- for my $bug (@bugs) {
- if ($param{check_archiveable}) {
- die "Bug $bug cannot be archived (but $param{bug} can?)"
- unless bug_archiveable(bug=>$bug,
- ignore_time => $param{ignore_time},
- );
- }
- }
- # If we get here, we can archive/remove this bug
- print {$debug} "$param{bug} removing\n";
- for my $bug (@bugs) {
- #print "$param{bug} removing $bug\n" if $debug;
- my $dir = get_hashname($bug);
- # First indicate that this bug is being archived
- append_action_to_log(bug => $bug,
- get_lock => 0,
- command => 'archive',
- # we didn't actually change the data
- # when we archived, so we don't pass
- # a real new_data or old_data
- new_data => {},
- old_data => {},
- __return_append_to_log_options(
- %param,
- action => $action,
- )
- )
- if not exists $param{append_log} or $param{append_log};
- my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
- if ($config{save_old_bugs}) {
- mkpath("$config{spool_dir}/archive/$dir");
- foreach my $file (@files_to_remove) {
- link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
- copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
- # we need to bail out here if things have
- # gone horribly wrong to avoid removing a
- # bug altogether
- die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
- }
-
- print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
- }
- unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
- print {$debug} "deleted $bug (from $param{bug})\n";
- }
- bughook_archive(@bugs);
- __end_control(%info);
-}
-
-=head2 bug_unarchive
-
- my $error = '';
- eval {
- bug_unarchive(bug => $bug_num,
- debug => \$debug,
- transcript => \$transcript,
- );
- };
- if ($@) {
- $errors++;
- transcript("Unable to archive bug: $bug_num");
- }
- transcript($transcript);
-
-This routine unarchives a bug
-
-=cut
-
-sub bug_unarchive {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+/,
- },
- %common_options,
- %append_action_options,
- },
- );
-
- my %info = __begin_control(%param,
- archived=>1,
- command=>'unarchive');
- my ($debug,$transcript) =
- @info{qw(debug transcript)};
- my @bugs = @{$info{bugs}};
- my $action = "$config{bug} unarchived.";
- my @files_to_remove;
- ## error out if we're unarchiving unarchived bugs
- for my $data (@{$info{data}}) {
- if (not defined $data->{archived} or
- not $data->{archived}
- ) {
- __end_control(%info);
- croak("Bug $data->{bug_num} was not archived; not unarchiving it.");
- }
- }
- for my $bug (@bugs) {
- print {$debug} "$param{bug} removing $bug\n";
- my $dir = get_hashname($bug);
- my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
- mkpath("archive/$dir");
- foreach my $file (@files_to_copy) {
- # die'ing here sucks
- link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
- copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
- die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
- }
- push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
- print {$transcript} "Unarchived $config{bug} $bug\n";
- }
- unlink(@files_to_remove) or die "Unable to unlink bugs";
- # Indicate that this bug has been archived previously
- for my $bug (@bugs) {
- my $newdata = readbug($bug);
- my $old_data = dclone($newdata);
- if (not defined $newdata) {
- print {$transcript} "$config{bug} $bug disappeared!\n";
- die "Bug $bug disappeared!";
- }
- $newdata->{unarchived} = time;
- append_action_to_log(bug => $bug,
- get_lock => 0,
- command => 'unarchive',
- new_data => $newdata,
- old_data => $old_data,
- __return_append_to_log_options(
- %param,
- action => $action,
- )
- )
- if not exists $param{append_log} or $param{append_log};
- writebug($bug,$newdata);
- }
- __end_control(%info);
-}
-
-=head2 append_action_to_log
-
- append_action_to_log
-
-This should probably be moved to Debbugs::Log; have to think that out
-some more.
-
-=cut
-
-sub append_action_to_log{
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+/,
- },
- new_data => {type => HASHREF,
- optional => 1,
- },
- old_data => {type => HASHREF,
- optional => 1,
- },
- command => {type => SCALAR,
- optional => 1,
- },
- action => {type => SCALAR,
- },
- requester => {type => SCALAR,
- default => '',
- },
- request_addr => {type => SCALAR,
- default => '',
- },
- location => {type => SCALAR,
- optional => 1,
- },
- message => {type => SCALAR|ARRAYREF,
- default => '',
- },
- recips => {type => SCALAR|ARRAYREF,
- optional => 1
- },
- desc => {type => SCALAR,
- default => '',
- },
- get_lock => {type => BOOLEAN,
- default => 1,
- },
- locks => {type => HASHREF,
- optional => 1,
- },
- # we don't use
- # append_action_options here
- # because some of these
- # options aren't actually
- # optional, even though the
- # original function doesn't
- # require them
- },
- );
- # Fix this to use $param{location}
- my $log_location = buglog($param{bug});
- die "Unable to find .log for $param{bug}"
- if not defined $log_location;
- if ($param{get_lock}) {
- filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
- $locks++;
- }
- my @records;
- my $logfh = IO::File->new(">>$log_location") or
- die "Unable to open $log_location for appending: $!";
- # determine difference between old and new
- my $data_diff = '';
- if (exists $param{old_data} and exists $param{new_data}) {
- my $old_data = dclone($param{old_data});
- my $new_data = dclone($param{new_data});
- for my $key (keys %{$old_data}) {
- if (not exists $Debbugs::Status::fields{$key}) {
- delete $old_data->{$key};
- next;
- }
- next unless exists $new_data->{$key};
- next unless defined $new_data->{$key};
- if (not defined $old_data->{$key}) {
- delete $old_data->{$key};
- next;
- }
- if (ref($new_data->{$key}) and
- ref($old_data->{$key}) and
- ref($new_data->{$key}) eq ref($old_data->{$key})) {
- local $Storable::canonical = 1;
- if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
- delete $new_data->{$key};
- delete $old_data->{$key};
- }
- }
- elsif ($new_data->{$key} eq $old_data->{$key}) {
- delete $new_data->{$key};
- delete $old_data->{$key};
- }
- }
- for my $key (keys %{$new_data}) {
- if (not exists $Debbugs::Status::fields{$key}) {
- delete $new_data->{$key};
- next;
- }
- next unless exists $old_data->{$key};
- next unless defined $old_data->{$key};
- if (not defined $new_data->{$key} or
- not exists $Debbugs::Status::fields{$key}) {
- delete $new_data->{$key};
- next;
- }
- if (ref($new_data->{$key}) and
- ref($old_data->{$key}) and
- ref($new_data->{$key}) eq ref($old_data->{$key})) {
- local $Storable::canonical = 1;
- if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
- delete $new_data->{$key};
- delete $old_data->{$key};
- }
- }
- elsif ($new_data->{$key} eq $old_data->{$key}) {
- delete $new_data->{$key};
- delete $old_data->{$key};
- }
- }
- $data_diff .= "<!-- new_data:\n";
- my %nd;
- for my $key (keys %{$new_data}) {
- if (not exists $Debbugs::Status::fields{$key}) {
- warn "No such field $key";
- next;
- }
- $nd{$key} = $new_data->{$key};
- # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
- }
- $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%nd)],[qw(new_data)]));
- $data_diff .= "-->\n";
- $data_diff .= "<!-- old_data:\n";
- my %od;
- for my $key (keys %{$old_data}) {
- if (not exists $Debbugs::Status::fields{$key}) {
- warn "No such field $key";
- next;
- }
- $od{$key} = $old_data->{$key};
- # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
- }
- $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%od)],[qw(old_data)]));
- $data_diff .= "-->\n";
- }
- my $msg = join('',
- (exists $param{command} ?
- "<!-- command:".html_escape(encode_utf8_safely($param{command}))." -->\n":""
- ),
- (length $param{requester} ?
- "<!-- requester: ".html_escape(encode_utf8_safely($param{requester}))." -->\n":""
- ),
- (length $param{request_addr} ?
- "<!-- request_addr: ".html_escape(encode_utf8_safely($param{request_addr}))." -->\n":""
- ),
- "<!-- time:".time()." -->\n",
- $data_diff,
- "<strong>".html_escape(encode_utf8_safely($param{action}))."</strong>\n");
- if (length $param{requester}) {
- $msg .= "Request was from <code>".html_escape(encode_utf8_safely($param{requester}))."</code>\n";
- }
- if (length $param{request_addr}) {
- $msg .= "to <code>".html_escape(encode_utf8_safely($param{request_addr}))."</code>";
- }
- if (length $param{desc}) {
- $msg .= ":<br>\n".encode_utf8_safely($param{desc})."\n";
- }
- else {
- $msg .= ".\n";
- }
- push @records, {type => 'html',
- text => $msg,
- };
- $msg = '';
- if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
- push @records, {type => exists $param{recips}?'recips':'incoming-recv',
- exists $param{recips}?(recips => [map {encode_utf8_safely($_)} make_list($param{recips})]):(),
- text => join('',make_list($param{message})),
- };
- }
- write_log_records(logfh=>$logfh,
- records => \@records,
- );
- close $logfh or die "Unable to close $log_location: $!";
- if ($param{get_lock}) {
- unfilelock(exists $param{locks}?$param{locks}:());
- $locks--;
- }
-
-
-}
-
-
-=head1 PRIVATE FUNCTIONS
-
-=head2 __handle_affected_packages
-
- __handle_affected_packages(affected_packages => {},
- data => [@data],
- )
-
-
-
-=cut
-
-sub __handle_affected_packages{
- my %param = validate_with(params => \@_,
- spec => {%common_options,
- data => {type => ARRAYREF|HASHREF
- },
- },
- allow_extra => 1,
- );
- for my $data (make_list($param{data})) {
- next unless exists $data->{package} and defined $data->{package};
- my @packages = split /\s*,\s*/,$data->{package};
- @{$param{affected_packages}}{@packages} = (1) x @packages;
- }
-}
-
-=head2 __handle_debug_transcript
-
- my ($debug,$transcript) = __handle_debug_transcript(%param);
-
-Returns a debug and transcript filehandle
-
-
-=cut
-
-sub __handle_debug_transcript{
- my %param = validate_with(params => \@_,
- spec => {%common_options},
- allow_extra => 1,
- );
- my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
- my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
- return ($debug,$transcript);
-}
-
-=head2 __bug_info
-
- __bug_info($data)
-
-Produces a small bit of bug information to kick out to the transcript
-
-=cut
-
-sub __bug_info{
- my $return = '';
- for my $data (@_) {
- next unless defined $data and exists $data->{bug_num};
- $return .= "Bug #".($data->{bug_num}||'').
- ((defined $data->{done} and length $data->{done})?
- " {Done: $data->{done}}":''
- ).
- " [".($data->{package}||'(no package)'). "] ".
- ($data->{subject}||'(no subject)')."\n";
- }
- return $return;
-}
-
-
-=head2 __internal_request
-
- __internal_request()
- __internal_request($level)
-
-Returns true if the caller of the function calling __internal_request
-belongs to __PACKAGE__
-
-This allows us to be magical, and don't bother to print bug info if
-the second caller is from this package, amongst other things.
-
-An optional level is allowed, which increments the number of levels to
-check by the given value. [This is basically for use by internal
-functions like __begin_control which are always called by
-C<__PACKAGE__>.
-
-=cut
-
-sub __internal_request{
- my ($l) = @_;
- $l = 0 if not defined $l;
- if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
- return 1;
- }
- return 0;
-}
-
-sub __return_append_to_log_options{
- my %param = @_;
- my $action = $param{action} if exists $param{action};
- if (not exists $param{requester}) {
- $param{requester} = $config{control_internal_requester};
- }
- if (not exists $param{request_addr}) {
- $param{request_addr} = $config{control_internal_request_addr};
- }
- if (not exists $param{message}) {
- my $date = rfc822_date();
- $param{message} =
- encode_headers(fill_in_template(template => 'mail/fake_control_message',
- variables => {request_addr => $param{request_addr},
- requester => $param{requester},
- date => $date,
- action => $action
- },
- ));
- }
- if (not defined $action) {
- carp "Undefined action!";
- $action = "unknown action";
- }
- return (action => $action,
- hash_slice(%param,keys %append_action_options),
- );
-}
-
-=head2 __begin_control
-
- my %info = __begin_control(%param,
- archived=>1,
- command=>'unarchive');
- my ($debug,$transcript) = @info{qw(debug transcript)};
- my @data = @{$info{data}};
- my @bugs = @{$info{bugs}};
-
-
-Starts the process of modifying a bug; handles all of the generic
-things that almost every control request needs
-
-Returns a hash containing
-
-=over
-
-=item new_locks -- number of new locks taken out by this call
-
-=item debug -- the debug file handle
-
-=item transcript -- the transcript file handle
-
-=item data -- an arrayref containing the data of the bugs
-corresponding to this request
-
-=item bugs -- an arrayref containing the bug numbers of the bugs
-corresponding to this request
-
-=back
-
-=cut
-
-our $lockhash;
-
-sub __begin_control {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+/,
- },
- archived => {type => BOOLEAN,
- default => 0,
- },
- command => {type => SCALAR,
- optional => 1,
- },
- %common_options,
- },
- allow_extra => 1,
- );
- my $new_locks;
- my ($debug,$transcript) = __handle_debug_transcript(@_);
- print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n";
-# print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n";
- $lockhash = $param{locks} if exists $param{locks};
- my @data = ();
- my $old_die = $SIG{__DIE__};
- $SIG{__DIE__} = *sig_die{CODE};
-
- ($new_locks, @data) =
- lock_read_all_merged_bugs(bug => $param{bug},
- $param{archived}?(location => 'archive'):(),
- exists $param{locks} ? (locks => $param{locks}):(),
- );
- $locks += $new_locks;
- if (not @data) {
- die "Unable to read any bugs successfully.";
- }
- if (not $param{archived}) {
- for my $data (@data) {
- if ($data->{archived}) {
- die "Not altering archived bugs; see unarchive.";
- }
- }
- }
- if (not check_limit(data => \@data,
- exists $param{limit}?(limit => $param{limit}):(),
- transcript => $transcript,
- )) {
- die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
- }
-
- __handle_affected_packages(%param,data => \@data);
- print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
- print {$debug} "$param{bug} read $locks locks\n";
- if (not @data or not defined $data[0]) {
- print {$transcript} "No bug found for $param{bug}\n";
- die "No bug found for $param{bug}";
- }
-
- add_recipients(data => \@data,
- recipients => $param{recipients},
- (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
- debug => $debug,
- (__internal_request()?(transcript => $transcript):()),
- );
-
- print {$debug} "$param{bug} read done\n";
- my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
- print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
- return (data => \@data,
- bugs => \@bugs,
- old_die => $old_die,
- new_locks => $new_locks,
- debug => $debug,
- transcript => $transcript,
- param => \%param,
- exists $param{locks}?(locks => $param{locks}):(),
- );
-}
-
-=head2 __end_control
-
- __end_control(%info);
-
-Handles tearing down from a control request
-
-=cut
-
-sub __end_control {
- my %info = @_;
- if (exists $info{new_locks} and $info{new_locks} > 0) {
- print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
- for (1..$info{new_locks}) {
- unfilelock(exists $info{locks}?$info{locks}:());
- $locks--;
- }
- }
- $SIG{__DIE__} = $info{old_die};
- if (exists $info{param}{affected_bugs}) {
- @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
- }
- add_recipients(recipients => $info{param}{recipients},
- (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
- data => $info{data},
- debug => $info{debug},
- transcript => $info{transcript},
- );
- __handle_affected_packages(%{$info{param}},data=>$info{data});
-}
-
-
-=head2 check_limit
-
- check_limit(data => \@data, limit => $param{limit});
-
-
-Checks to make sure that bugs match any limits; each entry of @data
-much satisfy the limit.
-
-Returns true if there are no entries in data, or there are no keys in
-limit; returns false (0) if there are any entries which do not match.
-
-The limit hashref elements can contain an arrayref of scalars to
-match; regexes are also acccepted. At least one of the entries in each
-element needs to match the corresponding field in all data for the
-limit to succeed.
-
-=cut
-
-
-sub check_limit{
- my %param = validate_with(params => \@_,
- spec => {data => {type => ARRAYREF|HASHREF,
- },
- limit => {type => HASHREF|UNDEF,
- },
- transcript => {type => SCALARREF|HANDLE,
- optional => 1,
- },
- },
- );
- my @data = make_list($param{data});
- if (not @data or
- not defined $param{limit} or
- not keys %{$param{limit}}) {
- return 1;
- }
- my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
- my $going_to_fail = 0;
- for my $data (@data) {
- $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
- status => dclone($data),
- ));
- for my $field (keys %{$param{limit}}) {
- next unless exists $param{limit}{$field};
- my $match = 0;
- my @data_fields = make_list($data->{$field});
-LIMIT: for my $limit (make_list($param{limit}{$field})) {
- if (not ref $limit) {
- for my $data_field (@data_fields) {
- if ($data_field eq $limit) {
- $match = 1;
- last LIMIT;
- }
- }
- }
- elsif (ref($limit) eq 'Regexp') {
- for my $data_field (@data_fields) {
- if ($data_field =~ $limit) {
- $match = 1;
- last LIMIT;
- }
- }
- }
- else {
- warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
- }
- }
- if (not $match) {
- $going_to_fail = 1;
- print {$transcript} qq($field: ').join(', ',map{qq("$_")} make_list($data->{$field})).
- "' does not match at least one of ".
- join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
- }
- }
- }
- return $going_to_fail?0:1;
-}
-
-
-=head2 die
-
- sig_die "foo"
-
-We override die to specially handle unlocking files in the cases where
-we are called via eval. [If we're not called via eval, it doesn't
-matter.]
-
-=cut
-
-sub sig_die{
- if ($^S) { # in eval
- if ($locks) {
- for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
- $locks = 0;
- }
- }
-}
-
-
-# =head2 __message_body_template
-#
-# message_body_template('mail/ack',{ref=>'foo'});
-#
-# Creates a message body using a template
-#
-# =cut
-
-sub __message_body_template{
- my ($template,$extra_var) = @_;
- $extra_var ||={};
- my $hole_var = {'&bugurl' =>
- sub{"$_[0]: ".
- $config{cgi_domain}.'/'.
- Debbugs::CGI::bug_links(bug => $_[0],
- links_only => 1,
- );
- }
- };
-
- my $body = fill_in_template(template => $template,
- variables => {config => \%config,
- %{$extra_var},
- },
- hole_var => $hole_var,
- );
- return fill_in_template(template => 'mail/message_body',
- variables => {config => \%config,
- %{$extra_var},
- body => $body,
- },
- hole_var => $hole_var,
- );
-}
-
-sub __all_undef_or_equal {
- my @values = @_;
- return 1 if @values == 1 or @values == 0;
- my $not_def = grep {not defined $_} @values;
- if ($not_def == @values) {
- return 1;
- }
- if ($not_def > 0 and $not_def != @values) {
- return 0;
- }
- my $first_val = shift @values;
- for my $val (@values) {
- if ($first_val ne $val) {
- return 0;
- }
- }
- return 1;
-}
-
-
-1;
-
-__END__
projects / debbugs.git / blobdiff