}
my $unmaintained_packages = 0;
# unmaintained packages is a special case
- for my $maint (make_list(exists $param{maint}?$param{maint}:[])) {
+ my @maints = make_list(exists $param{maint}?$param{maint}:[]);
+ $param{maint} = [];
+ for my $maint (@maints) {
if (defined $maint and $maint eq '' and not $unmaintained_packages) {
$unmaintained_packages = 1;
our %maintainers = %{getmaintainers()};
- $param{function} = [exists $param{function}?
- (ref $param{function}?@{$param{function}}:$param{function}):(),
+ $param{function} = [(exists $param{function}?
+ (ref $param{function}?@{$param{function}}:$param{function}):()),
sub {my %d=@_;
- foreach my $try (splitpackages($d{"pkg"})) {
+ foreach my $try (make_list($d{"pkg"})) {
+ next unless length $try;
+ ($try) = $try =~ m/^(?:src:)?(.+)/;
return 1 if not exists $maintainers{$try};
}
return 0;
}
];
}
+ elsif (defined $maint and $maint ne '') {
+ push @{$param{maint}},$maint;
+ }
}
# We handle src packages, maint and maintenc by mapping to the
# appropriate binary packages, then removing all packages which
my ($hash, $status) = @_;
foreach my $key( keys( %$hash ) ) {
my $value = $hash->{$key};
+ next unless exists $field_match{$key};
my $sub = $field_match{$key};
+ if (not defined $sub) {
+ die "No defined subroutine for key: $key";
+ }
return 1 if ($sub->($key, $value, $status));
}
return 0;
}
-=head HTML
+=head1 HTML
=head2 htmlize_packagelinks
%options,
$type => $_,
),
- $_);
+ ($type eq 'src'?'src:':'').$_);
} make_list($param{$type}) if exists $param{$type};
}
for my $type (qw(maint owner submitter correspondent)) {
sub maybelink {
my ($links,$regex,$join) = @_;
if (not defined $regex and not defined $join) {
- $links =~ s{((?:ftp|http|https)://[\S~-]+?/?)([\)\'\:\.\,]?(?:\s|\.<|$))}
- {q(<a href=").html_escape($1).q(">).html_escape($1).q(</a>).$2}geimo;
+ $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
+ {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
return $links;
}
$join = ' ' if not defined $join;
terse => $param{terse},
exists $param{msg}?(msg=>$param{msg}):(),
exists $param{att}?(att=>$param{att}):(),
+ exists $param{trim_headers}?(trim_headers=>$param{trim_headers}):(),
);
return $output;
my $header = '';
my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
- my @dummy = ($gRemoveAge); #, @gSeverityList, @gSeverityDisplay); #, $gHTMLExpireNote);
-
if (@bugs == 0) {
return "<HR><H2>No reports found!</H2></HR>\n";
}
@EXPORT = ();
%EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
qw(appendfile buglog getparsedaddrs getmaintainers),
+ qw(bug_status),
qw(getmaintainers_reverse),
qw(getpseudodesc),
],
- misc => [qw(make_list globify_scalar english_join checkpid)],
+ misc => [qw(make_list globify_scalar english_join checkpid),
+ qw(cleanup_eval_fail),
+ ],
date => [qw(secs_to_english)],
quit => [qw(quit)],
lock => [qw(filelock unfilelock lockpid)],
use Mail::Address;
use Cwd qw(cwd);
+use Params::Validate qw(validate_with :types);
+
use Fcntl qw(:flock);
our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
return undef;
}
+=head2 bug_status
+
+ bug_status($bugnum)
+
+
+Returns the path to the summary file corresponding to the bug.
+
+Returns undef if the bug does not exist.
+
+=cut
+
+sub bug_status{
+ my ($bugnum) = @_;
+ my $location = getbuglocation($bugnum, 'summary');
+ return getbugcomponent($bugnum, 'summary', $location) if ($location);
+ return undef;
+}
=head2 appendfile
=head2 english_join
- print english_join(', ',' and ',@list);
+ print english_join(list => \@list);
+ print english_join(\@list);
Joins list properly to make an english phrase.
+=over
+
+=item normal -- how to separate most values; defaults to ', '
+
+=item last -- how to separate the last two values; defaults to ', and '
+
+=item only_two -- how to separate only two values; defaults to ' and '
+
+=item list -- ARRAYREF values to join; if the first argument is an
+ARRAYREF, it's assumed to be the list of values to join
+
+=back
+In cases where C<list> is empty, returns ''; when there is only one
+element, returns that element.
=cut
sub english_join {
- my ($normal,$last,@list) = @_;
- if (@list <= 1) {
- return @list?$list[0]:'';
- }
- my $ret = $last . pop(@list);
- $ret = join($normal,@list) . $ret;
- return $ret;
+ if (ref $_[0] eq 'ARRAY') {
+ return english_join(list=>$_[0]);
+ }
+ my %param = validate_with(params => \@_,
+ spec => {normal => {type => SCALAR,
+ default => ', ',
+ },
+ last => {type => SCALAR,
+ default => ', and ',
+ },
+ only_two => {type => SCALAR,
+ default => ' and ',
+ },
+ list => {type => ARRAYREF,
+ },
+ },
+ );
+ my @list = @{$param{list}};
+ if (@list <= 1) {
+ return @list?$list[0]:'';
+ }
+ elsif (@list == 2) {
+ return join($param{only_two},@list);
+ }
+ my $ret = $param{last} . pop(@list);
+ return join($param{normal},@list) . $ret;
}
return IO::File->new('/dev/null','w');
}
+=head2 cleanup_eval_fail()
+
+ print "Something failed with: ".cleanup_eval_fail($@);
+
+Does various bits of cleanup on the failure message from an eval (or
+any other die message)
+
+Takes at most two options; the first is the actual failure message
+(usually $@ and defaults to $@), the second is the debug level
+(defaults to $DEBUG).
+
+If debug is non-zero, the code at which the failure occured is output.
+
+=cut
+
+sub cleanup_eval_fail {
+ my ($error,$debug) = @_;
+ if (not defined $error or not @_) {
+ $error = $@ || 'unknown reason';
+ }
+ if (@_ <= 1) {
+ $debug = $DEBUG || 0;
+ }
+ $debug = 0 if not defined $debug;
+
+ if ($debug > 0) {
+ return $error;
+ }
+ # ditch the "at foo/bar/baz.pm line 5"
+ $error =~ s/\sat\s\S+\sline\s\d+//;
+ # ditch trailing multiple periods in case there was a cascade of
+ # die messages.
+ $error =~ s/\.+$/\./;
+ return $error;
+}
+
1;
Default: $config{maintainer_email}
-=back
-
=cut
set_default(\%config,'unknown_maintainer_email',$config{maintainer_email});
=over
+=item mailer
+
+Name of the mailer to use
+
+Default: exim
+
=cut
set_default(\%config,'mailer','exim');
+
+
+=item bug
+
+Default: bug
+
+=item ubug
+
+Default: ucfirst($config{bug});
+
+=item bugs
+
+Default: bugs
+
+=item ubugs
+
+Default: ucfirst($config{ubugs});
+
+=cut
+
set_default(\%config,'bug','bug');
+set_default(\%config,'ubug',ucfirst($config{bug}));
set_default(\%config,'bugs','bugs');
+set_default(\%config,'ubugs',ucfirst($config{bugs}));
=item remove_age
#
# [Other people have contributed to this file; their copyrights should
# go here too.]
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+# Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::Control;
=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
$DEBUG = 0 unless defined $DEBUG;
@EXPORT = ();
- %EXPORT_TAGS = (affects => [qw(affects)],
+ %EXPORT_TAGS = (reopen => [qw(reopen)],
+ submitter => [qw(set_submitter)],
+ severity => [qw(set_severity)],
+ affects => [qw(affects)],
summary => [qw(summary)],
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)],
archive => [qw(bug_archive bug_unarchive),
],
log => [qw(append_action_to_log),
use Debbugs::Config qw(:config);
use Debbugs::Common qw(:lock buglog :misc get_hashname);
-use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages);
+use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages split_status_fields);
use Debbugs::CGI qw(html_escape);
use Debbugs::Log qw(:misc);
use Debbugs::Recipients qw(:add);
+use Debbugs::Packages qw(:versions :mapping);
use Params::Validate qw(validate_with :types);
use File::Path qw(mkpath);
use Debbugs::Text qw(:templates);
-use Debbugs::Mail qw(rfc822_date);
+use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
+use Debbugs::MIME qw(create_mime_message);
+
+use Mail::RFC822::Address qw();
use POSIX qw(strftime);
+use Storable qw(dclone nfreeze);
+use List::Util qw(first);
+
use Carp;
# These are a set of options which are common to all of these functions
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,
+ },
);
-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),
- ],
- },
- );
+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),
+ ],
+ },
+ );
+
+
+# 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 (exists $param{add}) {
+ $mode = 'add';
+ }
+ elsif (exists $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->{archive}) {
+ $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') {
+ croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
+ keys %ok_blockers?'':" and no known 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) {
+ croak "Unknown 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}) {
+ 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;
+ }
+ }
+ }
+ my @new_blockers = keys %blockers;
+ for my $data (@data) {
+ my $old_data = dclone($data);
+ # remove blockers and/or add new ones as appropriate
+ if ($data->{blockedby} eq '') {
+ print {$transcript} "Was not blocked by any bugs.\n";
+ } else {
+ print {$transcript} "Was blocked by: $data->{blockedby}\n";
+ }
+ my @changed;
+ push @changed, 'added blocking bug(s) '.english_join([keys %added_blockers]) if keys %added_blockers;
+ push @changed, 'removed blocking bug(s) '.english_join([keys %removed_blockers]) if keys %removed_blockers;
+ $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"
+ unless __internal_request();
+ 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;
+ for my $add_remove (keys %mungable_blocks) {
+ my @munge_blockers;
+ my %munge_blockers;
+ my $block_locks = 0;
+ for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
+ next if $munge_blockers{$blocker};
+ my ($new_locks, @blocking_data) =
+ lock_read_all_merged_bugs($blocker,
+ ($param{archived}?'archive':()));
+ if (not @blocking_data) {
+ unfilelock() for $new_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;
+ %blocks = split ' ', $data->{blocks};
+ my @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
+ )
+ );
+ }
+ __handle_affected_packages(%param,data=>\@blocking_data);
+ add_recipients(recipients => $param{recipients},
+ actions_taken => {blocks => 1},
+ data => \@blocking_data,
+ debug => $debug,
+ transcript => $transcript,
+ );
+
+ unfilelock() for $new_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 ($debug,$transcript) =
+ @info{qw(debug transcript)};
+ my @data = @{$info{data}};
+ my @bugs = @{$info{bugs}};
+ 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 %fixed_removed = ();
+ my @old_tags = split /\,\s*/, $data->{tags};
+ my %tags;
+ @tags{@old_tags} = (1) x @old_tags;
+ my $reopened = 0;
+ 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->{tags} = join(', ',keys %tags); # double check this
+
+ 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"
+ unless __internal_request();
+ 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 defafult 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 ($debug,$transcript) =
+ @info{qw(debug transcript)};
+ my @data = @{$info{data}};
+ my @bugs = @{$info{bugs}};
+
+ my $action = '';
+ for my $data (@data) {
+ if (not defined $data->{severity}) {
+ $data->{severity} = $param{severity};
+ $action = "Severity set to '$param{severity}'\n";
+ }
+ 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}'\n";
+ $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 reopen
+
+ 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 reopen {
+ my %param = validate_with(params => \@_,
+ spec => {bug => {type => SCALAR,
+ regex => qr/^\d+$/,
+ },
+ # specific options here
+ submitter => {type => SCALAR|UNDEF,
+ default => undef,
+ },
+ %common_options,
+ %append_action_options,
+ },
+ );
+
+ $param{submitter} = undef if defined $param{submitter} and
+ not length $param{submitter};
+
+ if (defined $param{submitter} and
+ 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 => 'reopen'
+ );
+ my ($debug,$transcript) =
+ @info{qw(debug transcript)};
+ my @data = @{$info{data}};
+ my @bugs = @{$info{bugs}};
+ my $action ='';
+
+ my $warn_fixed = 1; # avoid warning multiple times if there are
+ # fixed versions
+ my @change_submitter = ();
+ my @bugs_to_reopen = ();
+ 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} "you may need to use 'found' to remove fixed versions.\n";
+ $warn_fixed = 0;
+ }
+ if (defined $param{submitter} and length $param{submitter}
+ and $data->{originator} ne $param{submitter}) {
+ push @change_submitter,$data->{bug_num};
+ }
+ }
+ __end_control(%info);
+ my @params_for_subcalls =
+ map {exists $param{$_}?($_,$param{$_}):()}
+ (keys %common_options,
+ keys %append_action_options,
+ );
+
+ for my $bug (@change_submitter) {
+ set_submitter(bug=>$bug,
+ submitter => $param{submitter},
+ @params_for_subcalls,
+ );
+ }
+ set_fixed(fixed => [],
+ bug => $param{bug},
+ reopen => 1,
+ );
+}
+
+
+=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 @bugs = @{$info{bugs}};
+ 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"
+ unless __internal_request();
+ 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";
+ }
+ my %info =
+ __begin_control(%param,
+ command => 'forwarded'
+ );
+ my ($debug,$transcript) =
+ @info{qw(debug transcript)};
+ my @data = @{$info{data}};
+ my @bugs = @{$info{bugs}};
+ my $action = '';
+ for my $data (@data) {
+ my $old_data = dclone($data);
+ print {$debug} "Going to change bug forwarded\n";
+ if (((not defined $param{forwarded} or not length $param{forwarded}) and
+ (not defined $data->{forwarded} or not length $data->{forwarded})) or
+ $param{forwarded} eq $data->{forwarded}) {
+ print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
+ unless __internal_request();
+ 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 @bugs = @{$info{bugs}};
+ 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"
+ unless __internal_request();
+ 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}};
+ my @bugs = @{$info{bugs}};
+ # 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"
+ unless __internal_request();
+ 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 @bugs = @{$info{bugs}};
+ 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;
+ }
+ 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 {Debbugs::Versions::Dpkg::vercmp($a,$b);}
+ map {m{([^/]+)$}; $1;} @svers;
+ # determine if we need to reopen
+ my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
+ 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 = "$config{bug} ".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"
+ unless __internal_request();
+ 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 @bugs = @{$info{bugs}};
+ 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;
+ }
+ 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 = "$config{bug} ".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"
+ unless __internal_request();
+ 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);
+}
-# this is just a generic stub for Debbugs::Control functions.
-#
-# =head2 foo
-#
-# eval {
-# 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 foo $ref bar: $@";
-# }
-#
-# Foo frobinates
-#
-# =cut
-#
-# sub foo {
-# my %param = validate_with(params => \@_,
-# spec => {bug => {type => SCALAR,
-# regex => qr/^\d+$/,
-# },
-# # specific options here
-# %common_options,
-# %append_action_options,
-# },
-# );
-# our $locks = 0;
-# $locks = 0;
-# local $SIG{__DIE__} = sub {
-# if ($locks) {
-# for (1..$locks) { unfilelock(); }
-# $locks = 0;
-# }
-# };
-# my ($debug,$transcript) = __handle_debug_transcript(%param);
-# my (@data);
-# ($locks, @data) = lock_read_all_merged_bugs($param{bug});
-# __handle_affected_packages(data => \@data,%param);
-# print {$transcript} __bug_info(@data);
-# add_recipients(data => \@data,
-# recipients => $param{recipients}
-# debug => $debug,
-# transcript => $transcript,
-# );
-# 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";
-# add_recipients(data => $data,
-# recipients => $param{recipients},
-# debug => $debug,
-# transcript => $transcript,
-# );
-# }
-# if ($locks) {
-# for (1..$locks) { unfilelock(); }
-# }
-#
-# }
=head2 affects
if ($param{add} and $param{remove}) {
croak "Asking to both add and remove affects is nonsensical";
}
- our $locks = 0;
- $locks = 0;
- local $SIG{__DIE__} = sub {
- if ($locks) {
- for (1..$locks) { unfilelock(); }
- $locks = 0;
- }
- };
- my ($debug,$transcript) = __handle_debug_transcript(%param);
- my (@data);
- ($locks, @data) = lock_read_all_merged_bugs($param{bug});
- __handle_affected_packages(data => \@data,%param);
- print {$transcript} __bug_info(@data);
- add_recipients(data => \@data,
- recipients => $param{recipients},
- debug => $debug,
- transcript => $transcript,
- );
- my $action = 'Did not alter affected packages';
+ my %info =
+ __begin_control(%param,
+ command => 'affects'
+ );
+ my ($debug,$transcript) =
+ @info{qw(debug transcript)};
+ my @data = @{$info{data}};
+ my @bugs = @{$info{bugs}};
+ my $action = '';
for my $data (@data) {
+ $action = '';
print {$debug} "Going to change affects\n";
my @packages = splitpackages($data->{affects});
my %packages;
if ($param{add}) {
my @added = ();
for my $package (make_list($param{packages})) {
- if (not $packages{$package}) {
- $packages{$package} = 1;
- push @added,$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(', ',' and ',@added);
+ english_join(\@added);
}
}
elsif ($param{remove}) {
my @removed = ();
for my $package (make_list($param{packages})) {
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(', ',' and ',@removed);
+ english_join(\@removed);
}
else {
+ my %added_packages = ();
+ my %removed_packages = %packages;
%packages = ();
for my $package (make_list($param{packages})) {
+ 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([%added_packages]);
}
- $action = "Noted that $data->{bug_num} affects ".
- english_join(', ',' and ', keys %packages);
}
+ if (not length $action) {
+ print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
+ unless __internal_request();
+ }
+ 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";
- add_recipients(data => $data,
- recipients => $param{recipients},
- debug => $debug,
- transcript => $transcript,
- );
- }
- if ($locks) {
- for (1..$locks) { unfilelock(); }
}
-
+ __end_control(%info);
}
},
);
croak "summary must be numeric or undef" if
- defined $param{summary} and not $param{summary} =~ /^\d+$/;
- our $locks = 0;
- $locks = 0;
- local $SIG{__DIE__} = sub {
- if ($locks) {
- for (1..$locks) { unfilelock(); }
- $locks = 0;
- }
- };
- my ($debug,$transcript) = __handle_debug_transcript(%param);
- my (@data);
- ($locks, @data) = lock_read_all_merged_bugs($param{bug});
- __handle_affected_packages(data => \@data,%param);
- print {$transcript} __bug_info(@data);
- add_recipients(data => \@data,
- recipients => $param{recipients},
- debug => $debug,
- transcript => $transcript,
- );
+ defined $param{summary} and not $param{summary} =~ /^\d+$/;
+ my %info =
+ __begin_control(%param,
+ command => 'summary'
+ );
+ my ($debug,$transcript) =
+ @info{qw(debug transcript)};
+ my @data = @{$info{data}};
+ my @bugs = @{$info{bugs}};
# figure out the log that we're going to use
my $summary = '';
my $summary_msg = '';
my $action = '';
if (not defined $param{summary}) {
# do nothing
- print {$debug} "Removing summary fields";
+ print {$debug} "Removing summary fields\n";
$action = 'Removed summary';
}
else {
}
print {$debug} "Summary is going to be '$paragraph'\n";
$summary = $paragraph;
- $summary =~ s/[\n\r]//g;
+ $summary =~ s/[\n\r]/ /g;
if (not length $summary) {
die "Unable to find summary message to use";
}
- # trim off a trailing space
- $summary =~ s/\ $//;
+ # trim off a trailing spaces
+ $summary =~ s/\ *$//;
}
for my $data (@data) {
- print {$debug} "Going to change summary";
+ print {$debug} "Going to change summary\n";
+ if (((not defined $summary or not length $summary) and
+ (not defined $data->{summary} or not length $data->{summary})) or
+ $summary eq $data->{summary}) {
+ print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
+ unless __internal_request();
+ next;
+ }
if (length $summary) {
if (length $data->{summary}) {
$action = "Summary replaced with message bug $param{bug} message $summary_msg";
$action = "Summary recorded from message bug $param{bug} message $summary_msg";
}
}
+ my $old_data = dclone($data);
$data->{summary} = $summary;
append_action_to_log(bug => $data->{bug_num},
+ command => 'summary',
+ old_data => $old_data,
+ new_data => $data,
get_lock => 0,
__return_append_to_log_options(
%param,
if not exists $param{append_log} or $param{append_log};
writebug($data->{bug_num},$data);
print {$transcript} "$action\n";
- add_recipients(data => $data,
- recipients => $param{recipients},
- debug => $debug,
- transcript => $transcript,
- );
}
- if ($locks) {
- for (1..$locks) { unfilelock(); }
- }
-
+ __end_control(%info);
}
%append_action_options,
},
);
- our $locks = 0;
- $locks = 0;
- local $SIG{__DIE__} = sub {
- if ($locks) {
- for (1..$locks) { unfilelock(); }
- $locks = 0;
- }
- };
- my ($debug,$transcript) = __handle_debug_transcript(%param);
- my (@data);
- ($locks, @data) = lock_read_all_merged_bugs($param{bug});
- __handle_affected_packages(data => \@data,%param);
- print {$transcript} __bug_info(@data);
- @data and defined $data[0] or die "No bug found for $param{bug}";
- add_recipients(data => \@data,
- recipients => $param{recipients},
- debug => $debug,
- transcript => $transcript,
- );
+ my %info =
+ __begin_control(%param,
+ command => 'owner',
+ );
+ my ($debug,$transcript) =
+ @info{qw(debug transcript)};
+ my @data = @{$info{data}};
+ my @bugs = @{$info{bugs}};
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}) {
- $param{owner} = '';
- $action = "Removed annotation that $config{bug} was owned by " .
- "$data->{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"
+ unless __internal_request();
+ next;
+ }
+ $param{owner} = '';
+ $action = "Removed annotation that $config{bug} was owned by " .
+ "$data->{owner}.";
}
else {
- if (length $data->{owner}) {
- $action = "Owner changed from $data->{owner} to $param{owner}.";
- }
- else {
- $action = "Owner recorded as $param{owner}."
- }
+ 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,
if not exists $param{append_log} or $param{append_log};
writebug($data->{bug_num},$data);
print {$transcript} "$action\n";
- add_recipients(data => $data,
- recipients => $param{recipients},
- debug => $debug,
- transcript => $transcript,
- );
- }
- if ($locks) {
- for (1..$locks) { unfilelock(); }
}
+ __end_control(%info);
}
%append_action_options,
},
);
- our $locks = 0;
- $locks = 0;
- local $SIG{__DIE__} = sub {
- if ($locks) {
- for (1..$locks) { unfilelock(); }
- $locks = 0;
- }
- };
+ 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.";
- my ($debug,$transcript) = __handle_debug_transcript(%param);
if ($param{check_archiveable} and
not bug_archiveable(bug=>$param{bug},
ignore_time => $param{ignore_time},
die "Bug $param{bug} cannot be archived";
}
print {$debug} "$param{bug} considering\n";
- my (@data);
- ($locks, @data) = lock_read_all_merged_bugs($param{bug});
- __handle_affected_packages(data => \@data,%param);
- print {$transcript} __bug_info(@data);
- print {$debug} "$param{bug} read $locks\n";
- @data and defined $data[0] or die "No bug found for $param{bug}";
- print {$debug} "$param{bug} read done\n";
-
if (not $param{archive_unarchived} and
not exists $data[0]{unarchived}
) {
debug => $debug,
transcript => $transcript,
);
- my @bugs = map {$_->{bug_num}} @data;
print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
for my $bug (@bugs) {
if ($param{check_archiveable}) {
# 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 ($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" );
+ 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";
print {$transcript} "deleted $bug (from $param{bug})\n";
}
bughook_archive(@bugs);
- if (exists $param{bugs_affected}) {
- @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
- }
- print {$debug} "$param{bug} unlocking $locks\n";
- if ($locks) {
- for (1..$locks) { unfilelock(); }
- }
- print {$debug} "$param{bug} unlocking done\n";
+ __end_control(%info);
}
=head2 bug_unarchive
%append_action_options,
},
);
- our $locks = 0;
- local $SIG{__DIE__} = sub {
- if ($locks) {
- for (1..$locks) { unfilelock(); }
- $locks = 0;
- }
- };
+
+ my %info = __begin_control(%param,
+ archived=>1,
+ command=>'unarchive');
+ my ($debug,$transcript) =
+ @info{qw(debug transcript)};
+ my @data = @{$info{data}};
+ my @bugs = @{$info{bugs}};
my $action = "$config{bug} unarchived.";
- my ($debug,$transcript) = __handle_debug_transcript(%param);
- print {$debug} "$param{bug} considering\n";
- my @data = ();
- ($locks, @data) = lock_read_all_merged_bugs($param{bug},'archive');
- __handle_affected_packages(data => \@data,%param);
- print {$transcript} __bug_info(@data);
- print {$debug} "$param{bug} read $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}";
- }
- 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";
- print {$debug} "$param{bug} unarchiving\n";
my @files_to_remove;
for my $bug (@bugs) {
print {$debug} "$param{bug} removing $bug\n";
# 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);
- add_recipients(recipients => $param{recipients},
- data => $newdata,
- debug => $debug,
- transcript => $transcript,
- );
- }
- print {$debug} "$param{bug} unlocking $locks\n";
- if ($locks) {
- for (1..$locks) { unfilelock(); };
- }
- if (exists $param{bugs_affected}) {
- @{$param{bugs_affected}}{@bugs} = (1) x @bugs;
}
- print {$debug} "$param{bug} unlocking done\n";
+ __end_control(%info);
}
=head2 append_action_to_log
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,
get_lock => {type => BOOLEAN,
default => 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});
}
my $log = IO::File->new(">>$log_location") or
die "Unable to open $log_location for appending: $!";
- my $msg = "\6\n".
- "<!-- time:".time." -->\n".
- "<strong>".html_escape($param{action})."</strong>\n";
+ # 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;
+ # print STDERR Dumper($new_data,$old_data,$key);
+ 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([\%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([\%od],[qw(old_data)]));
+ $data_diff .= "-->\n";
+ }
+ my $msg = join('',"\6\n",
+ (exists $param{command} ?
+ "<!-- command:".html_escape($param{command})." -->\n":""
+ ),
+ (length $param{requester} ?
+ "<!-- requester: ".html_escape($param{requester})." -->\n":""
+ ),
+ (length $param{request_addr} ?
+ "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
+ ),
+ "<!-- time:".time()." -->\n",
+ $data_diff,
+ "<strong>".html_escape($param{action})."</strong>\n");
if (length $param{requester}) {
$msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
}
);
for my $data (make_list($param{data})) {
next unless exists $data->{package} and defined $data->{package};
- $param{affected_packages}{$data->{package}} = 1;
- }
+ my @packages = split /\s*,\s*/,$data->{package};
+ @{$param{affected_packages}}{@packages} = (1) x @packages;
+ }
}
=head2 __handle_debug_transcript
sub __bug_info{
my $return = '';
for my $data (@_) {
- $return .= "Bug ".($data->{bug_num}||'').
- " [".($data->{package}||''). "] ".
- ($data->{subject}||'')."\n";
+ 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(2+$l))[0] and +(caller(2+$l))[0] eq __PACKAGE__) {
+ return 1;
+ }
+ return 0;
+}
+
sub __return_append_to_log_options{
my %param = @_;
my $action = $param{action} if exists $param{action};
);
}
+=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 $locks = 0;
+
+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} "$param{bug} considering\n";
+ my @data = ();
+ my $old_die = $SIG{__DIE__};
+ $SIG{__DIE__} = *sig_die{CODE};
+
+ ($new_locks, @data) =
+ lock_read_all_merged_bugs($param{bug},
+ ($param{archived}?'archive':()));
+ $locks += $new_locks;
+ if (not @data) {
+ die "Unable to read any bugs successfully.";
+ }
+ if (not __check_limit(data => \@data,
+ exists $param{limit}?(limit => $param{limit}):(),
+ )) {
+ 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,
+ 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,
+ );
+}
+
+=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();
+ }
+ }
+ $SIG{__DIE__} = $info{old_die};
+ if (exists $info{param}{bugs_affected}) {
+ @{$info{param}{bugs_affected}}{@{$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|SCALAR,
+ },
+ limit => {type => HASHREF|UNDEF,
+ },
+ },
+ );
+ my @data = make_list($param{data});
+ if (not @data or
+ not defined $param{limit} or
+ not keys %{$param{limit}}) {
+ return 1;
+ }
+ for my $data (@data) {
+ for my $field (keys %{$param{limit}}) {
+ next unless exists $param{limit}{$field};
+ my $match = 0;
+ for my $limit (make_list($param{limit}{$field})) {
+ if (not ref $limit) {
+ if ($data->{$field} eq $limit) {
+ $match = 1;
+ last;
+ }
+ }
+ elsif (ref($limit) eq 'Regexp') {
+ if ($data->{$field} =~ $limit) {
+ $match = 1;
+ last;
+ }
+ }
+ else {
+ warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
+ }
+ }
+ if (not $match) {
+ return 0;
+ }
+ }
+ }
+ return 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(); }
+ $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]: ".
+ 'http://'.$config{cgi_domain}.'/'.
+ Debbugs::CGI::bug_url($_[0]);
+ }
+ };
+
+ 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,
+ );
+}
+
1;
Takes a filehandle and a list of records as input, and prints the .log
format representation of those records to that filehandle.
+=back
+
=cut
sub write_log_records (*@)
}
-=back
-
=head1 CAVEATS
This module does none of the formatting that bugreport.cgi et al do. It's
package Debbugs::MIME;
+=head1 NAME
+
+Debbugs::MIME -- Mime handling routines for debbugs
+
+=head1 SYNOPSIS
+
+ use Debbugs::MIME qw(parse decode_rfc1522);
+
+=head1 DESCRIPTION
+
+
+=head1 BUGS
+
+None known.
+
+=cut
+
+use warnings;
use strict;
use base qw(Exporter);
}
use File::Path;
+use File::Temp qw();
use MIME::Parser;
use POSIX qw(strftime);
my (@headerlines, @bodylines);
my $parser = MIME::Parser->new();
- mkdir "mime.tmp.$$", 0777;
- $parser->output_under("mime.tmp.$$");
+ my $tempdir = File::Temp::tempdir();
+ $parser->output_under($tempdir);
my $entity = eval { $parser->parse_data($_[0]) };
if ($entity and $entity->head->tags) {
@bodylines = @msg[$i .. $#msg];
}
- rmtree "mime.tmp.$$", 0, 1;
+ rmtree $tempdir, 0, 1;
# Remove blank lines.
shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
use Debbugs::Config qw(:config);
use Params::Validate qw(:types validate_with);
+use Debbugs::Packages;
+
BEGIN{
($VERSION) = q$Revision: 1.1 $ =~ /^Revision:\s+([^\s+])/;
$DEBUG = 0 unless defined $DEBUG;
@EXPORT = ();
- @EXPORT_OK = qw(send_mail_message get_addresses encode_headers rfc822_date);
+ %EXPORT_TAGS = (addresses => [qw(get_addresses)],
+ misc => [qw(rfc822_date)],
+ mail => [qw(send_mail_message encode_headers default_headers)],
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
$EXPORT_TAGS{all} = [@EXPORT_OK];
-
}
# We set this here so it can be overridden for testing purposes
}
+=head2 default_headers
+
+ my @head = default_headers(queue_file => 'foo',
+ data => $data,
+ msgid => $header{'message-id'},
+ msgtype => 'error',
+ headers => [...],
+ );
+ create_mime_message(\@headers,
+ ...
+ );
+
+This function is generally called to generate the headers for
+create_mime_message (and anything else that needs a set of default
+headers.)
+
+In list context, returns an array of headers. In scalar context,
+returns headers for shoving in a mail message after encoding using
+encode_headers.
+
+=head3 options
+
+=over
+
+=item queue_file -- the queue file which will generate this set of
+headers (refered to as $nn in lots of the code)
+
+=item data -- the data of the bug which this message involves; can be
+undefined if there is no bug involved.
+
+=item msgid -- the Message-ID: of the message which will generate this
+set of headers
+
+=item msgtype -- the type of message that this is.
+
+=item pr_msg -- the pr message field
+
+=item headers -- a set of headers which will override the default
+headers; these headers will be passed through (and may be reordered.)
+If a particular header is undef, it overrides the default, but isn't
+passed through.
+
+=back
+
+=head3 default headers
+
+=over
+
+=item X-Loop -- set to the maintainer e-mail
+
+=item From -- set to the maintainer e-mail
+
+=item To -- set to Unknown recipients
+
+=item Subject -- set to Unknown subject
+
+=item Message-ID -- set appropriately (see code)
+
+=item Precedence -- set to bulk
+
+=item References -- set to the full set of message ids that are known
+(from data and the msgid option)
+
+=item In-Reply-To -- set to msg id or the msgid from data
+
+=item X-Project-PR-Message -- set to pr_msg with the bug number appended
+
+=item X-Project-PR-Package -- set to the package of the bug
+
+=item X-Project-PR-Keywords -- set to the keywords of the bug
+
+=item X-Project-PR-Source -- set to the source of the bug
+
+=back
+
+=cut
+
+sub default_headers {
+ my %param = validate_with(params => \@_,
+ spec => {queue_file => {type => SCALAR,
+ optional => 1,
+ },
+ data => {type => HASHREF,
+ optional => 1,
+ },
+ msgid => {type => SCALAR,
+ optional => 1,
+ },
+ msgtype => {type => SCALAR,
+ default => 'misc',
+ optional => 1,
+ },
+ pr_msg => {type => SCALAR,
+ default => 'misc',
+ },
+ headers => {type => ARRAYREF,
+ default => [],
+ },
+ },
+ );
+ my @header_order = (qw(X-Loop From To subject),
+ qw(Message-ID In-Reply-To References));
+ my %header_order;
+ @header_order{map {lc $_} @header_order} = 0..$#header_order;
+ my %set_headers;
+ my @ordered_headers;
+ my @temp = @{$param{headers}};
+ my @other_headers;
+ while (my ($header,$value) = splice @temp,0,2) {
+ if (exists $header_order{lc($header)}) {
+ push @{$ordered_headers[$header_order{lc($header)}]},
+ ($header,$value);
+ }
+ else {
+ push @other_headers,($header,$value);
+ }
+ $set_headers{lc($header)} = 1;
+ }
+
+ # calculate our headers
+ my $bug_num = exists $param{data} ? $param{data}{bug_num} : 'x';
+ my $nn = $param{queue_file};
+ # handle the user giving the actual queue filename instead of nn
+ $nn =~ s/^[a-zA-Z]([a-zA-Z])/$1/;
+ $nn = lc($nn);
+ my @msgids;
+ if (exists $param{msgid} and defined $param{msgid}) {
+ push @msgids, $param{msgid}
+ }
+ elsif (exists $param{data} and defined $param{data}{msgid}) {
+ push @msgids, $param{data}{msgid}
+ }
+ my %default_header;
+ $default_header{'X-Loop'} = $config{maintainer_email};
+ $default_header{From} = "$config{maintainer_email} ($config{project} $config{ubug} Tracking System)";
+ $default_header{To} = "Unknown recipients";
+ $default_header{Subject} = "Unknown subject";
+ $default_header{'Message-ID'} = "<handler.${bug_num}.${nn}.$param{msgtype}\@$config{email_domain}>";
+ if (@msgids) {
+ $default_header{'In-Reply-To'} = $msgids[0];
+ $default_header{'References'} = join(' ',@msgids);
+ }
+ $default_header{Precedence} = 'bulk';
+ $default_header{"X-$config{project}-PR-Message"} = $param{pr_msg} . (exists $param{data} ? ' '.$param{data}{bug_num}:'');
+ $default_header{Date} = rfc822_date();
+ if (exists $param{data}) {
+ if (defined $param{data}{keywords}) {
+ $default_header{"X-$config{project}-PR-Keywords"} = $param{data}{keywords};
+ }
+ if (defined $param{data}{package}) {
+ $default_header{"X-$config{project}-PR-Package"} = $param{data}{package};
+ if ($param{data}{package} =~ /^src:(.+)$/) {
+ $default_header{"X-$config{project}-PR-Source"} = $1;
+ }
+ else {
+ my $pkg_src = Debbugs::Packages::getpkgsrc();
+ $default_header{"X-$config{project}-PR-Source"} = $pkg_src->{$param{data}{package}};
+ }
+ }
+ }
+ for my $header (sort keys %default_header) {
+ next if $set_headers{lc($header)};
+ if (exists $header_order{lc($header)}) {
+ push @{$ordered_headers[$header_order{lc($header)}]},
+ ($header,$default_header{$header});
+ }
+ else {
+ push @other_headers,($header,$header_order{lc($header)});
+ }
+ }
+ my @headers;
+ for my $hdr1 (@ordered_headers) {
+ next if not defined $hdr1;
+ my @temp = @{$hdr1};
+ while (my ($header,$value) = splice @temp,0,2) {
+ next if not defined $value;
+ push @headers,($header,$value);
+ }
+ }
+ push @headers,@other_headers;
+ if (wantarray) {
+ return @headers;
+ }
+ else {
+ my $headers = '';
+ while (my ($header,$value) = splice @headers,0,2) {
+ $headers .= "${header}: $value\n";
+ }
+ return $headers;
+ }
+}
+
+
=head2 send_mail_message
use base qw(Exporter);
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
+use Carp;
+
use Debbugs::Config qw(:config :globals);
BEGIN {
$VERSION = 1.00;
@EXPORT = ();
- %EXPORT_TAGS = (versions => [qw(getversions get_versions)],
+ %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)],
mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
qw(binarytosource sourcetobinary makesourceversions)
],
use MLDBM qw(DB_File Storable);
use Storable qw(dclone);
use Params::Validate qw(validate_with :types);
-use Debbugs::Common qw(make_list);
+use Debbugs::Common qw(make_list globify_scalar);
use List::Util qw(min max);
=head1 METHODS
-=over 8
-
-=item getpkgsrc
+=head2 getpkgsrc
Returns a reference to a hash of binary package names to their corresponding
source package names.
return $_pkgsrc;
}
-=item getpkgcomponent
+=head2 getpkgcomponent
Returns a reference to a hash of binary package names to the component of
the archive containing those binary packages (e.g. "main", "contrib",
return $_pkgcomponent;
}
-=item getsrcpkgs
+=head2 getsrcpkgs
Returns a list of the binary packages produced by a given source package.
return @{$_srcpkg->{$src}};
}
-=item binarytosource
+=head2 binarytosource
Returns a reference to the source package name and version pair
corresponding to a given binary package name, version, and architecture.
elsif (exists $binary{$binver}) {
if (defined $binarch) {
my $src = $binary{$binver}{$binarch};
+ if (not defined $src and exists $binary{$binver}{all}) {
+ $src = $binary{$binver}{all};
+ }
return () unless defined $src; # not on this arch
# Copy the data to avoid tiedness problems.
return dclone($src);
return ();
}
-=item sourcetobinary
+=head2 sourcetobinary
Returns a list of references to triplets of binary package names, versions,
and architectures corresponding to a given source package name and version.
# avoid autovivification
my $source = $_sourcetobinary{$srcname};
return () unless defined $source;
- my %source = %{$source};
- if (exists $source{$srcver}) {
- my $bin = $source{$srcver};
+ if (exists $source->{$srcver}) {
+ my $bin = $source->{$srcver};
return () unless defined $bin;
return @$bin;
}
return map [$_, $srcver], @srcpkgs;
}
-=item getversions
+=head2 getversions
Returns versions of the package in a distribution at a specific
architecture
for my $arch (exists $param{arch}?
make_list($param{arch}):
(grep {not $param{no_source_arch} or
- $_ ne 'source'
- } keys %{$version->{$dist}})) {
+ $_ ne 'source'
+ } keys %{$version->{$dist}})) {
next unless defined $version->{$dist}{$arch};
for my $ver (ref $version->{$dist}{$arch} ?
keys %{$version->{$dist}{$arch}} :
) {
my $f_ver = $ver;
if ($param{source}) {
- ($f_ver) = makesourceversions($package,$arch,$ver);
+ ($f_ver) = make_source_versions(package => $package,
+ arch => $arch,
+ versions => $ver);
next unless defined $f_ver;
}
if ($param{time}) {
}
-=item makesourceversions
+=head2 makesourceversions
@{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
our %_sourceversioncache = ();
sub makesourceversions {
- my $pkg = shift;
- my $arch = shift;
- my %sourceversions;
- die "Package $pkg is multiple packages; split on , and call makesourceversions multiple times"
- if $pkg =~ /,/;
+ my ($package,$arch,@versions) = @_;
+ die "Package $package is multiple packages; split on , and call makesourceversions multiple times"
+ if $package =~ /,/;
+ return make_source_versions(package => $package,
+ (defined $arch)?(arch => $arch):(),
+ versions => \@versions
+ );
+}
+
+=head2 make_source_versions
+
+ make_source_versions(package => 'foo',
+ arch => 'source',
+ versions => '0.1.1',
+ guess_source => 1,
+ debug => \$debug,
+ warnings => \$warnings,
+ );
+
+An extended version of makesourceversions (which calls this function
+internally) that allows for multiple packages, architectures, and
+outputs warnings and debugging information to provided SCALARREFs or
+HANDLEs.
+
+The guess_source option determines whether the source package is
+guessed at if there is no obviously correct package. Things that use
+this function for non-transient output should set this to false,
+things that use it for transient output can set this to true.
+Currently it defaults to true, but that is not a sane option.
+
+
+=cut
- for my $version (@_) {
- if ($version =~ m[/]) {
+sub make_source_versions {
+ my %param = validate_with(params => \@_,
+ spec => {package => {type => SCALAR|ARRAYREF,
+ },
+ arch => {type => SCALAR|ARRAYREF|UNDEF,
+ default => ''
+ },
+ versions => {type => SCALAR|ARRAYREF,
+ default => [],
+ },
+ guess_source => {type => BOOLEAN,
+ default => 1,
+ },
+ source_version_cache => {type => HASHREF,
+ optional => 1,
+ },
+ debug => {type => SCALARREF|HANDLE,
+ optional => 1,
+ },
+ warnings => {type => SCALARREF|HANDLE,
+ optional => 1,
+ },
+ },
+ );
+ my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef);
+ my ($debug) = globify_scalar(exists $param{debug} ?$param{debug} :undef);
+
+ my @packages = grep {defined $_ and length $_ } make_list($param{package});
+ my @archs = grep {defined $_ } make_list ($param{arch});
+ if (not @archs) {
+ push @archs, '';
+ }
+ if (not exists $param{source_version_cache}) {
+ $param{source_version_cache} = \%_sourceversioncache;
+ }
+ if (grep {/,/} make_list($param{package})) {
+ croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages"
+ }
+ my %sourceversions;
+ for my $version (make_list($param{versions})) {
+ if ($version =~ m{(.+)/([^/]+)$}) {
+ # check to see if this source version is even possible
+ my @bin_versions = sourcetobinary($1,$2);
+ if (not @bin_versions or
+ @{$bin_versions[0]} != 3) {
+ print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n";
+ }
# Already a source version.
$sourceversions{$version} = 1;
} else {
- my $cachearch = (defined $arch) ? $arch : '';
- my $cachekey = "$pkg/$cachearch/$version";
- if (exists($_sourceversioncache{$cachekey})) {
- for my $v (@{$_sourceversioncache{$cachekey}}) {
- $sourceversions{$v} = 1;
+ if (not @packages) {
+ croak "You must provide at least one package if the versions are not fully qualified";
+ }
+ for my $pkg (@packages) {
+ for my $arch (@archs) {
+ my $cachearch = (defined $arch) ? $arch : '';
+ my $cachekey = "$pkg/$cachearch/$version";
+ if (exists($param{source_version_cache}{$cachekey})) {
+ for my $v (@{$param{source_version_cache}{$cachekey}}) {
+ $sourceversions{$v} = 1;
+ }
+ next;
+ }
+ elsif ($param{guess_source} and
+ exists$param{source_version_cache}{$cachekey.'/guess'}) {
+ for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) {
+ $sourceversions{$v} = 1;
+ }
+ next;
+ }
+ my @srcinfo = binarytosource($pkg, $version, $arch);
+ if (not @srcinfo) {
+ # We don't have explicit information about the
+ # binary-to-source mapping for this version
+ # (yet).
+ print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n";
+ if ($param{guess_source}) {
+ # Lets guess it
+ my $pkgsrc = getpkgsrc();
+ if (exists $pkgsrc->{$pkg}) {
+ @srcinfo = ([$pkgsrc->{$pkg}, $version]);
+ } elsif (getsrcpkgs($pkg)) {
+ # If we're looking at a source package
+ # that doesn't have a binary of the
+ # same name, just try the same
+ # version.
+ @srcinfo = ([$pkg, $version]);
+ } else {
+ next;
+ }
+ # store guesses in a slightly different location
+ $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+ }
+ }
+ else {
+ # only store this if we didn't have to guess it
+ $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+ }
+ $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
}
- next;
- }
-
- my @srcinfo = binarytosource($pkg, $version, $arch);
- unless (@srcinfo) {
- # We don't have explicit information about the
- # binary-to-source mapping for this version (yet). Since
- # this is a CGI script and our output is transient, we can
- # get away with just looking in the unversioned map; if it's
- # wrong (as it will be when binary and source package
- # versions differ), too bad.
- my $pkgsrc = getpkgsrc();
- if (exists $pkgsrc->{$pkg}) {
- @srcinfo = ([$pkgsrc->{$pkg}, $version]);
- } elsif (getsrcpkgs($pkg)) {
- # If we're looking at a source package that doesn't have
- # a binary of the same name, just try the same version.
- @srcinfo = ([$pkg, $version]);
- } else {
- next;
- }
- }
- $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
- $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+ }
}
}
-
return sort keys %sourceversions;
}
-=back
-
-=cut
-
1;
#
# [Other people have contributed to this file; their copyrights should
# go here too.]
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+# Copyright 2007-9 by Don Armstrong <don@donarmstrong.com>.
package Debbugs::Status;
use Debbugs::Common qw(:util :lock :quit :misc);
use Debbugs::Config qw(:config);
use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
-use Debbugs::Packages qw(makesourceversions getversions get_versions binarytosource);
+use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binarytosource);
use Debbugs::Versions;
use Debbugs::Versions::Dpkg;
use POSIX qw(ceil);
+use Storable qw(dclone);
use List::Util qw(min max);
+use Carp qw(croak);
BEGIN{
$VERSION = 1.00;
@EXPORT = ();
%EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
- qw(isstrongseverity bug_presence),
+ qw(isstrongseverity bug_presence split_status_fields),
],
read => [qw(readbug read_bug lockreadbug lockreadbugmerge),
qw(lock_read_all_merged_bugs),
qw(removefoundversions removefixedversions)
],
hook => [qw(bughook bughook_archive)],
+ fields => [qw(%fields)],
);
@EXPORT_OK = ();
- Exporter::export_ok_tags(qw(status read write versions hook));
+ Exporter::export_ok_tags(qw(status read write versions hook fields));
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
=cut
-
-my %fields = (originator => 'submitter',
+# these probably shouldn't be imported by most people, but
+# Debbugs::Control needs them, so they're now exportable
+our %fields = (originator => 'submitter',
date => 'date',
subject => 'subject',
msgid => 'message-id',
affects => 'affects',
);
+
# Fields which need to be RFC1522-decoded in format versions earlier than 3.
my @rfc1522_fields = qw(originator subject done forwarded owner);
$data{$field} = decode_rfc1522($data{$field});
}
}
+ my $status_modified = (stat($status))[9];
# Add log last modified time
$data{log_modified} = (stat($log))[9];
+ $data{last_modified} = max($status_modified,$data{log_modified});
$data{location} = $location;
$data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
$data{bug_num} = $param{bug};
return \%data;
}
+=head2 split_status_fields
+
+ my @data = split_status_fields(@data);
+
+Splits splittable status fields (like package, tags, blocks,
+blockedby, etc.) into arrayrefs (use make_list on these). Keeps the
+passed @data intact using dclone.
+
+In scalar context, returns only the first element of @data.
+
+=cut
+
+our $ditch_empty = sub{
+ my @t = @_;
+ my $splitter = shift @t;
+ return grep {length $_} map {split $splitter} @t;
+};
+
+my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
+my %split_fields =
+ (package => \&splitpackages,
+ affects => \&splitpackages,
+ blocks => $ditch_empty_space,
+ blockedby => $ditch_empty_space,
+ tags => sub {return &{$ditch_empty}(qr/\s*\,\s*/,@_)},
+ found_versions => $ditch_empty_space,
+ fixed_versions => $ditch_empty_space,
+ mergedwith => $ditch_empty_space,
+ );
+
+sub split_status_fields {
+ my @data = @{dclone(\@_)};
+ for my $data (@data) {
+ next if not defined $data;
+ croak "Passed an element which is not a hashref to split_status_field".ref($data) if
+ not (ref($data) and ref($data) eq 'HASH');
+ for my $field (keys %{$data}) {
+ next unless defined $data->{$field};
+ if (exists $split_fields{$field}) {
+ next if ref($data->{$field});
+ my @elements;
+ if (ref($split_fields{$field}) eq 'CODE') {
+ @elements = &{$split_fields{$field}}($data->{$field});
+ }
+ elsif (not ref($split_fields{$field}) or
+ UNIVERSAL::isa($split_fields{$field},'Regex')
+ ) {
+ @elements = split $split_fields{$field}, $data->{$field};
+ }
+ if (@elements != 1) {
+ $data->{$field} = \@elements;
+ }
+ else {
+ $data->{$field} = $elements[0];
+ }
+ }
+ }
+ }
+ return wantarray?@data:$data[0];
+}
+
+=head2 join_status_fields
+
+ my @data = join_status_fields(@data);
+
+Handles joining the splitable status fields. (Basically, the inverse
+of split_status_fields.
+
+Primarily called from makestatus, but may be useful for other
+functions after calling split_status_fields (or for legacy functions
+if we transition to split fields by default).
+
+=cut
+
+sub join_status_fields {
+ my %join_fields =
+ (package => ', ',
+ affects => ', ',
+ blocks => ' ',
+ blockedby => ' ',
+ tags => ', ',
+ found_versions => ' ',
+ fixed_versions => ' ',
+ found_date => ' ',
+ fixed_date => ' ',
+ mergedwith => ' ',
+ );
+ my @data = @{dclone(\@_)};
+ for my $data (@data) {
+ next if not defined $data;
+ croak "Passed an element which is not a hashref to split_status_field: ".
+ ref($data)
+ if ref($data) ne 'HASH';
+ for my $field (keys %{$data}) {
+ next unless defined $data->{$field};
+ next unless ref($data->{$field}) eq 'ARRAY';
+ next unless exists $join_fields{$field};
+ $data->{$field} = join($join_fields{$field},@{$data->{$field}});
+ }
+ }
+ return wantarray?@data:$data[0];
+}
+
+
=head2 lockreadbug
lockreadbug($bug_num,$location)
my $locks = 0;
my @data = (lockreadbug(@_));
if (not @data or not defined $data[0]) {
- return ($locks,undef);
+ return ($locks,());
}
$locks++;
if (not length $data[0]->{mergedwith}) {
if (not @data or not defined $data[0]) {
unfilelock(); #for merge lock above
$locks--;
- return ($locks,undef);
+ return ($locks,());
}
$locks++;
my @bugs = split / /, $data[0]->{mergedwith};
}
$locks = 0;
warn "Unable to read bug: $bug while handling merged bug: $bug_num";
- return ($locks,undef);
+ return ($locks,());
}
$locks++;
push @data,$newdata;
[map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
}
}
-
- for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
- $newdata{$field} = join ' ', @{$newdata{$field}||[]};
- }
+ %newdata = %{join_status_fields(\%newdata)};
if ($version < 3) {
for my $field (@rfc1522_fields) {
sub splitpackages {
my $pkgs = shift;
return unless defined $pkgs;
- return map lc, split /[ \t?,()]+/, $pkgs;
+ return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
}
"source/version" format.] Eventually this can be used to for caching.
=item indicatesource -- if true, indicate which source packages this
-bug could belong to. Defaults to false. [Note that eventually we will
-properly allow bugs that only affect a source package, and this will
-become always on.]
+bug could belong to (or does belong to in the case of bugs assigned to
+a source package). Defaults to true.
=back
optional => 1,
},
indicatesource => {type => BOOLEAN,
- default => 0,
+ default => 1,
},
},
);
$status{tags} = $status{keywords};
my %tags = map { $_ => 1 } split ' ', $status{tags};
+ $status{package} = '' if not defined $status{package};
$status{"package"} =~ s/\s*$//;
- if ($param{indicatesource} and $status{package} ne '') {
- $status{source} = join(', ',binarytosource($status{package}));
- }
- else {
- $status{source} = 'unknown';
+ # if we aren't supposed to indicate the source, we'll return
+ # unknown here.
+ $status{source} = 'unknown';
+ if ($param{indicatesource}) {
+ my @packages = split /\s*,\s*/, $status{package};
+ my @source;
+ for my $package (@packages) {
+ next if $package eq '';
+ if ($package =~ /^src\:$/) {
+ push @source,$1;
+ }
+ else {
+ push @source, binarytosource($package);
+ }
+ }
+ if (@source) {
+ $status{source} = join(', ',@source);
+ }
}
+
$status{"package"} = 'unknown' if ($status{"package"} eq '');
- $status{"severity"} = 'normal' if ($status{"severity"} eq '');
+ $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
$status{"pending"} = 'pending';
$status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
$allowed_distributions{$tag} = 1;
}
}
- foreach my $arch (make_list($param{arch})) {
+ foreach my $arch (make_list(exists $param{arch}?$param{arch}:undef)) {
for my $package (split /\s*,\s*/, $status{package}) {
- my @versions;
- foreach my $dist (make_list($param{dist})) {
+ my @versions = ();
+ my $source = 0;
+ if ($package =~ /^src:(.+)$/) {
+ $source = 1;
+ $package = $1;
+ }
+ foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
# if some distributions are disallowed,
# and this isn't an allowed
# distribution, then we ignore this
not exists $allowed_distributions{$dist}) {
next;
}
- push @versions, getversions($package, $dist, $arch);
+ push @versions, get_versions(package => $package,
+ dist => $dist,
+ ($source?(arch => 'source'):
+ (defined $arch?(arch => $arch):())),
+ );
}
next unless @versions;
- my @temp = makesourceversions($package,
- $arch,
- @versions
- );
+ my @temp = make_source_versions(package => $package,
+ arch => $arch,
+ versions => \@versions,
+ );
@sourceversions{@temp} = (1) x @temp;
}
}
--- /dev/null
+^debian(?:\/|.*)$
+^\.bzr.*$
+^\.shelf.*$
+(?:^|\/)\.exists
+(?:^|\/)\.\#
+^blib(?:\/|.*)$
+~$
\ No newline at end of file
--- /dev/null
+# CrossAssassin.pm 2004/04/12 blarson
+
+package Mail::CrossAssassin;
+
+use strict;
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(ca_init ca_keys ca_set ca_score ca_expire);
+our $VERSION = 0.1;
+
+use Digest::MD5 qw(md5_base64);
+use DB_File;
+
+our %database;
+our $init;
+our $addrpat = '\b\d{3,8}(?:-(?:close|done|forwarded|maintonly|submitter|quiet))?\@bugs\.debian\.org';
+
+sub ca_init(;$$) {
+ my $ap = shift;
+ $addrpat = $ap if(defined $ap);
+ my $dir = shift;
+ return if ($init && ! defined($dir));
+ $dir = "$ENV{'HOME'}/.crosssassassin" unless (defined($dir));
+ (mkdir $dir or die "Could not create \"$dir\"") unless (-d $dir);
+ untie %database;
+ tie %database, 'DB_File', "$dir/Crossdb"
+ or die "Could not initialize crosassasin database \"$dir/Crossdb\": $!";
+ $init = 1;
+}
+
+sub ca_keys($) {
+ my $body = shift;
+ my @keys;
+ my $m = join('',@$body);
+ $m =~ s/\n(?:\s*\n)+/\n/gm;
+ if (length($m) > 4000) {
+ my $m2 = $m;
+ $m2 =~ s/\S\S+/\*/gs;
+ push @keys, '0'.md5_base64($m2);
+ }
+# $m =~ s/^--.*$/--/m;
+ $m =~ s/$addrpat/LOCAL\@ADDRESS/iogm;
+ push @keys, '1'.md5_base64($m);
+ return join(' ',@keys);
+}
+
+sub ca_set($) {
+ my @keys = split(' ', $_[0]);
+ my $now = time;
+ my $score = 0;
+ my @scores;
+ foreach my $k (@keys) {
+ my ($count,$date) = split(' ',$database{$k});
+ $count++;
+ $score = $count if ($count > $score);
+ $database{$k} = "$count $now";
+ push @scores, $count;
+ }
+ return (wantarray ? @scores : $score);
+}
+
+sub ca_score($) {
+ my @keys = split(' ', $_[0]);
+ my $score = 0;
+ my @scores;
+ my $i = 0;
+ foreach my $k (@keys) {
+ my ($count,$date) = split(' ',$database{$k});
+ $score = $count if ($count > $score);
+ $i++;
+ push @scores, $count;
+ }
+ return (wantarray ? @scores : $score);
+}
+
+sub ca_expire($) {
+ my $when = shift;
+ my @ret;
+ my $num = 0;
+ my $exp = 0;
+ while (my ($k, $v) = each %database) {
+ $num++;
+ my ($count, $date) = split(' ', $v);
+ if ($date <= $when) {
+ delete $database{$k};
+ $exp++;
+ }
+ }
+ return ($num, $exp);
+}
+
+END {
+ return unless($init);
+ untie %database;
+ undef($init);
+}
+
+1;
man8_dir := $(man_dir)/man8
examples_dir := $(doc_dir)/examples
-scripts_in := $(foreach script, $(filter-out scripts/config scripts/errorlib scripts/text, $(wildcard scripts/*)),$(patsubst scripts/%,%,$(script)))
+scripts_in = $(foreach script, $(filter-out scripts/config% scripts/errorlib scripts/text, $(wildcard scripts/*)),$(patsubst scripts/%,%,$(script)))
htmls_in := $(wildcard html/*.html.in)
cgis := $(wildcard cgi/*.cgi cgi/*.pl)
install_exec := install -m755 -p
install_data := install -m644 -p
-test:
- perl -MTest::Harness -I. -e 'runtests(glob(q(t/*.t)))'
+PERL ?= /usr/bin/perl
+
+all: build test
+
+build:
+ $(PERL) Makefile.PL
+ $(MAKE) -f Makefile.perl
+
+test: build
+ $(PERL) -MTest::Harness -I. -e 'runtests(glob(q(t/*.t)))'
+
+clean:
+ if [ -e Makefile.perl ]; then \
+ $(MAKE) -f Makefile.perl clean; \
+ fi;
install: install_mostfiles
# install basic debbugs documentation
# install the scripts
- $(foreach script,$(scripts_in), $(exec $(install_exec) $(script) $(scripts_dir)/$(script)))
+ $(foreach script,$(scripts_in), $(install_exec) scripts/$(script) $(scripts_dir);)
$(install_data) scripts/errorlib $(scripts_dir)/errorlib
# install examples
$(foreach tmpl, $(wildcard templates/*/*/*.tmpl), $(exec $(install_data) $(tmpl) $(template_dir)/$(patsubst templates/%,%,$(tmpl))))
-.PHONY: test
\ No newline at end of file
+.PHONY: test build
\ No newline at end of file
use ExtUtils::MakeMaker;
WriteMakefile(FIRST_MAKEFILE => 'Makefile.perl',
- PMLIBDIRS => ['Debbugs'],
+ PMLIBDIRS => ['Debbugs','Mail'],
EXE_FILES => ['bin/local-debbugs',
'bin/add_bug_to_estraier',
],
=head1 NAME
-add_bug_to_estraier
+add_bug_to_estraier -- add a bug log to an estraier database
=head1 SYNOPSIS
use Debbugs::Log qw(read_log_records);
use Debbugs::CGI qw(:url :html :util);
use Debbugs::CGI::Bugreport qw(:all);
-use Debbugs::Common qw(buglog getmaintainers make_list);
+use Debbugs::Common qw(buglog getmaintainers make_list bug_status);
use Debbugs::Packages qw(getpkgsrc);
use Debbugs::Status qw(splitpackages get_bug_status isstrongseverity);
use Debbugs::Text qw(:templates);
+use List::Util qw(max);
+
use CGI::Simple;
my $q = new CGI::Simple;
my %ut;
my %seen_users;
+my $buglog = buglog($ref);
+my $bug_status = bug_status($ref);
+if (not defined $buglog or not defined $bug_status) {
+ print $q->header(-status => "404 No such bug",
+ -type => "text/html",
+ -charset => 'utf-8',
+ );
+ print fill_in_template(template=>'cgi/no_such_bug',
+ variables => {modify_time => strftime('%a, %e %b %Y %T UTC', gmtime),
+ bug_num => $ref,
+ },
+ );
+ exit 0;
+}
+
+# the log should almost always be newer, but just in case
+my $log_mtime = +(stat $buglog)[9] || time;
+my $status_mtime = +(stat $bug_status)[9] || time;
+my $mtime = strftime '%a, %d %b %Y %T GMT', gmtime(max($status_mtime,$log_mtime));
+
+if ($q->request_method() eq 'HEAD' and not defined($att) and not $mbox) {
+ print $q->header(-type => "text/html",
+ -charset => 'utf-8',
+ (length $mtime)?(-last_modified => $mtime):(),
+ );
+ exit 0;
+}
+
for my $user (map {split /[\s*,\s*]+/} make_list($param{users}||[])) {
next unless length($user);
add_user($user,\%ut,\%bugusertags,\%seen_users);
my $archive = $param{'archive'} eq 'yes';
my $repeatmerged = $param{'repeatmerged'} eq 'yes';
-my $buglog = buglog($ref);
-if (not defined $buglog) {
- print $q->header(-status => "404 No such bug",
- -type => "text/html",
- -charset => 'utf-8',
- );
- print fill_in_template(template=>'cgi/no_such_bug',
- variables => {modify_time => strftime('%a, %e %b %Y %T UTC', gmtime),
- bug_num => $ref,
- },
- );
- exit 0;
-}
-
-my @stat = stat $buglog;
-my $mtime = '';
-if (@stat) {
- $mtime = strftime '%a, %d %b %Y %T GMT', gmtime($stat[9]);
-}
-
-if ($q->request_method() eq 'HEAD' and not defined($att) and not $mbox) {
- print $q->header(-type => "text/html",
- -charset => 'utf-8',
- (length $mtime)?(-last_modified => $mtime):(),
- );
- exit 0;
-}
my $buglogfh;
msg_num => $msg_num,
att => $att,
msg => $msg,
+ trim_headers => $trim_headers,
);
exit 0;
}
my @packages = splitpackages($status{package});
foreach my $pkg (@packages) {
- $package{$pkg} = {maintainer => exists($maintainer{$pkg}) ? $maintainer{$pkg} : '(unknown)',
- exists($pkgsrc{$pkg}) ? (source => $pkgsrc{$pkg}) : (),
- package => $pkg,
- };
+ if ($pkg =~ /^src\:/) {
+ my ($srcpkg) = $pkg =~ /^src:(.*)/;
+ $package{$pkg} = {maintainer => exists($maintainer{$srcpkg}) ? $maintainer{$srcpkg} : '(unknown)',
+ source => $srcpkg,
+ package => $pkg,
+ is_source => 1,
+ };
+ }
+ else {
+ $package{$pkg} = {maintainer => exists($maintainer{$pkg}) ? $maintainer{$pkg} : '(unknown)',
+ exists($pkgsrc{$pkg}) ? (source => $pkgsrc{$pkg}) : (),
+ package => $pkg,
+ };
+ }
}
# fixup various bits of the status
delete $param{maintenc}
}
-
-if (not grep {exists $param{$_}} keys %package_search_keys and exists $param{users}) {
- $param{usertag} = [make_list($param{users})];
-}
-
if (exists $param{pkg}) {
$param{package} = $param{pkg};
delete $param{pkg};
}
+if (not grep {exists $param{$_}} keys %package_search_keys and exists $param{users}) {
+ $param{usertag} = [make_list($param{users})];
+}
+
my %bugusertags;
my %ut;
my %seen_users;
delete $param{dist};
}
-# output infomration about the packages
+# output information about the packages
for my $package (make_list($param{package}||[])) {
print generate_package_info(binary => 1,
-debbugs (2.4.2) UNRELEASED; urgency=low
+debbugs (2.4.2~exp0) UNRELEASED; urgency=low
[ Anthony Towns ]
* Add "package" command to service (control@) to limit the bugs that
(closes: #465332,#458822)
* Deal properly with \r line endings (closes: #467190)
* Distinguish between reports and followups (closes: #459866)
- * Allow for the archiving of bugs in removed packages (closes: #475622, #470146)
+ * Allow for the archiving of bugs in removed packages
+ (closes: #475622, #470146)
* Add Text::Template based templating system (closes: #36814)
* Add new uservalue feature to Debbugs::User
* Don't serialize things as date/time in soap (closes: #484789)
* Link to packages in bugreport page (closes: #229067)
* Totally revamp the pkgreport templates (closes: #434504)
* Add correspondent option to track bug correpondents (closes: #485804)
+ * Fix addition of correspondents in gen-indices (closes: #511850)
* Allow clicking anywhere outside the extra status box to close the
extra status box (closes: #499990) Thanks to James Vega for the patch.
* Return 404 when a bug number that does not exist is used
* Display link to full log again (closes: #507506)
* Add Last-Modified: header support to mbox download (closes: #456786)
* Add Date headers if missing (closes: #458757)
- * Indiciate what machine has built webpages (closes: #507022)
+ * Indicate what machine has built webpages (closes: #507022)
+ * Indicate the update location of source (closes: #512306)
+ * Use get_addresses to parse X-Debbugs-Cc: to allow multiple Cc:'s
+ (closes: #514183)
+ * Calculate last modified using summary as well as log (closes: #515063)
+ * Ditch 'as before' (closes: #514677)
+ * Don't have reply/subscribe links for archived bugs (closes: #511864)
+ * Fix issue with no-maintainer bugs assigned to multiple packages
+ (closes: #528249)
+ * Properly html_escape un-processed parts in maybelink (closes: #530506)
+ * Add urls to the bottom of all messages we send out (closes: #9596)
+ * Allow for tag nnn = baz + foo - bar in service (closes: #505189)
+ * Allow trailinng periods after the control stop commands (closes:
+ #517834)
-- Colin Watson <cjwatson@debian.org> Fri, 20 Jun 2003 18:57:25 +0100
Priority: extra
Maintainer: Debbugs developers <debian-debbugs@lists.debian.org>
Uploaders: Josip Rodin <joy-packages@debian.org>, Colin Watson <cjwatson@debian.org>, Don Armstrong <don@debian.org>
-Standards-Version: 3.2.1
+Standards-Version: 3.8.1
Build-Depends-Indep: debhelper, libparams-validate-perl,
- libmailtools-perl, libmime-perl, libio-stringy-perl, libmldbm-perl,
+ libmailtools-perl, libmime-tools-perl, libio-stringy-perl, libmldbm-perl,
liburi-perl, libsoap-lite-perl, libcgi-simple-perl,
libhttp-server-simple-perl, libtest-www-mechanize-perl,
libmail-rfc822-address-perl, libsafe-hole-perl, libuser-perl,
- libconfig-simple-perl
+ libconfig-simple-perl, libtest-pod-perl
Package: debbugs
Architecture: all
Package: libdebbugs-perl
Architecture: all
-Depends: ${perl:Depends}, libmailtools-perl, ed, libmime-perl,
+Depends: ${perl:Depends}, libmailtools-perl, ed, libmime-tools-perl,
libio-stringy-perl, libmldbm-perl, liburi-perl, libsoap-lite-perl,
libcgi-simple-perl, libparams-validate-perl, libtext-template-perl,
libsafe-hole-perl, libmail-rfc822-address-perl
+Section: perl
Description: modules used by the active Debian BTS
Debian has a bug tracking system which files details of bugs reported by
users and developers. Each bug is given a number, and is kept on file until
merchantability or fitness for a particular purpose. See the GNU General
Public License for more details.
-You should have received a copy of the GNU General Public License along
-with this program, or one should be available above; if not, write to the
-Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
+You should have received a copy of the GNU General Public License
+along with this program. If not, see <http://www.gnu.org/licenses/>.
On Debian systems, the full text of the GPL can be found in
-/usr/share/common-licenses/GPL.
+/usr/share/common-licenses/GPL-2.
+
+
+Portions of the bug system copyrighted by Don Armstrong are available
+under the terms of the GPL version 2 or later, at your option.
\ No newline at end of file
+++ /dev/null
-/etc/debbugs/html/Access.html.in
-/etc/debbugs/html/Developer.html.in
-/etc/debbugs/html/Reporting.html.in
-/etc/debbugs/html/index.html.in
-/etc/debbugs/html/server-control.html.in
-/etc/debbugs/html/server-refcard.html.in
-/etc/debbugs/html/server-request.html.in
usr/share/man/man8
usr/sbin
usr/share/doc/debbugs/examples
-var/lib/debbugs
+var/lib/debbugs/spool
+var/lib/debbugs/indices
usr/bin/add_bug_to_estraier
usr/share/man/man1/add_bug_*
+# there currently isn't a Mail::Crossassassin manpage
+#usr/share/man/man3/Mail*
+usr/share/perl5/Mail*
\ No newline at end of file
+++ /dev/null
-etc/debbugs/html
-etc/debbugs/indices
-usr/lib/debbugs
-usr/sbin
-usr/share/doc/debbugs/examples
-var/lib/debbugs/indices
-var/lib/debbugs/www/cgi
-var/lib/debbugs/www/db
-var/lib/debbugs/www/txt
-var/lib/debbugs/spool/lock
-var/lib/debbugs/spool/archive
-var/lib/debbugs/spool/incoming
-var/lib/debbugs/spool/db-h
-usr/share/man/man3
-usr/share/perl5
+usr/share/man/man3/Debbugs*
+usr/share/perl5/Debbugs*
#etc/debbugs/config
+++ /dev/null
-#!/bin/sh -e
-
-if [ "$1" = "configure" ]; then
- /usr/sbin/debbugsconfig
- if dpkg --compare-versions "$2" lt 2.4; then
- spool=`perl -e 'require "/etc/debbugs/config"; print $gSpoolDir;'`
- if [ -d "$spool/db" ]; then
- if [ -d "$spool/db-h" ]; then
- echo "Cannot migrate bug database to hashed format, because" >&2
- echo "$spool/db-h already exists." >&2
- echo "Rectify the situation and run the following command by hand:" >&2
- echo " /usr/sbin/debbugs-dbhash \"$spool/db\" \"$spool/db-h\"" >&2
- else
- echo "Migrating bug database to hashed format." >&2
- /usr/sbin/debbugs-dbhash "$spool/db" "$spool/db-h"
- echo "You can remove bug logs from $spool/db" >&2
- echo "after ensuring that the new database works." >&2
- fi
- fi
- fi
-fi
-
-if [ -f /etc/debbugs/nextnumber ]; then
- rm -f /etc/debbugs/nextnumber
-fi
-
-#DEBHELPER#
+++ /dev/null
-#!/bin/sh
-
-if [ "$1" = "purge" ]; then
- rm -rf /etc/debbugs /var/lib/debbugs
-fi
-
-#DEBHELPER#
dh_installdirs
$(MAKE) install_mostfiles DESTDIR=$(DEST_DIR)
$(MAKE) -f Makefile.perl install PREFIX=$(DEST_DIR)/usr
- dh_install --sourcedir=debian/tmp --list-missing
+ dh_install --sourcedir=debian/tmp --fail-missing
dh_installdocs
dh_installchangelogs
dh_strip
if [ "$suite" != "oldstable" ] || [ -d /org/bugs.debian.org/etc/indices/$archive/$suite ]; then
case $suite in
oldstable|stable|proposed-updates)
- ARCHES='alpha arm hppa i386 ia64 m68k mips mipsel powerpc s390 sparc'
+ ARCHES='alpha amd64 arm hppa i386 ia64 m68k mips mipsel powerpc s390 sparc'
;;
testing|testing-proposed-updates)
ARCHES='alpha amd64 arm hppa i386 ia64 mips mipsel powerpc s390 sparc'
+++ /dev/null
-# CrossAssassin.pm 2004/04/12 blarson
-
-package Mail::CrossAssassin;
-
-use strict;
-require Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT = qw(ca_init ca_keys ca_set ca_score ca_expire);
-our $VERSION = 0.1;
-
-use Digest::MD5 qw(md5_base64);
-use DB_File;
-
-our %database;
-our $init;
-our $addrpat = '\b\d{3,8}(?:-(?:close|done|forwarded|maintonly|submitter|quiet))?\@bugs\.debian\.org';
-
-sub ca_init(;$$) {
- my $ap = shift;
- $addrpat = $ap if(defined $ap);
- my $dir = shift;
- return if ($init && ! defined($dir));
- $dir = "$ENV{'HOME'}/.crosssassassin" unless (defined($dir));
- (mkdir $dir or die "Could not create \"$dir\"") unless (-d $dir);
- untie %database;
- tie %database, 'DB_File', "$dir/Crossdb"
- or die "Could not initialize crosassasin database \"$dir/Crossdb\": $!";
- $init = 1;
-}
-
-sub ca_keys($) {
- my $body = shift;
- my @keys;
- my $m = join('',@$body);
- $m =~ s/\n(?:\s*\n)+/\n/gm;
- if (length($m) > 4000) {
- my $m2 = $m;
- $m2 =~ s/\S\S+/\*/gs;
- push @keys, '0'.md5_base64($m2);
- }
-# $m =~ s/^--.*$/--/m;
- $m =~ s/$addrpat/LOCAL\@ADDRESS/iogm;
- push @keys, '1'.md5_base64($m);
- return join(' ',@keys);
-}
-
-sub ca_set($) {
- my @keys = split(' ', $_[0]);
- my $now = time;
- my $score = 0;
- my @scores;
- foreach my $k (@keys) {
- my ($count,$date) = split(' ',$database{$k});
- $count++;
- $score = $count if ($count > $score);
- $database{$k} = "$count $now";
- push @scores, $count;
- }
- return (wantarray ? @scores : $score);
-}
-
-sub ca_score($) {
- my @keys = split(' ', $_[0]);
- my $score = 0;
- my @scores;
- my $i = 0;
- foreach my $k (@keys) {
- my ($count,$date) = split(' ',$database{$k});
- $score = $count if ($count > $score);
- $i++;
- push @scores, $count;
- }
- return (wantarray ? @scores : $score);
-}
-
-sub ca_expire($) {
- my $when = shift;
- my @ret;
- my $num = 0;
- my $exp = 0;
- while (my ($k, $v) = each %database) {
- $num++;
- my ($count, $date) = split(' ', $v);
- if ($date <= $when) {
- delete $database{$k};
- $exp++;
- }
- }
- return ($num, $exp);
-}
-
-END {
- return unless($init);
- untie %database;
- undef($init);
-}
-
-1;
use File::stat;
use List::Util qw(min);
+use Debbugs::Common qw(make_list);
+
=head1 NAME
gen-indices - Generates index files for the cgi scripts
use Debbugs::Config qw(:config);
use Debbugs::Common qw(getparsedaddrs getbugcomponent lockpid);
-use Debbugs::Status qw(readbug);
+use Debbugs::Status qw(readbug split_status_fields);
use Debbugs::Log;
chdir($config{spool_dir}) or die "chdir $config{spool_dir} failed: $!";
}
# NB: The reverse index is special; it's used to clean up during updates to bugs
-my @indexes = ('package', 'tag', 'severity','owner','submitter-email','status','correspondent','reverse');
+my @indexes = ('package', 'tag', 'severity','owner','submitter-email','status','correspondent','affects','reverse');
my $indexes;
my %slow_index = ();
my %fast_index = ();
next;
}
next if $stat->mtime < $time;
- my $fdata = readbug($bug, $initialdir);
+ my $fdata = split_status_fields(readbug($bug, $initialdir));
$modification_made = 1;
- addbugtoindex("package", $bug, split /[\s,]+/, $fdata->{"package"});
- addbugtoindex("tag", $bug, split /[\s,]+/, $fdata->{"keywords"});
+ addbugtoindex("package", $bug, make_list($fdata->{package}));
+ addbugtoindex("tag", $bug, make_list($fdata->{keywords}));
+ addbugtoindex("affects", $bug, make_list($fdata->{"affects"}));
addbugtoindex('submitter-email', $bug,
map {lc($_->address)} getparsedaddrs($fdata->{originator}));
addbugtoindex("severity", $bug, $fdata->{"severity"});
# handle log entries
# do this in eval to avoid exploding on jacked logs
eval {
- my $log = Debbugs::Log->new(bug_num => $bug);
- while (my $record = $log->read_record()) {
- next unless $record->{type} eq 'incoming-recv';
- # we use a regex here, because a full mime parse will be slow.
- my ($from) = $record->{text} =~ /^From:\s+(.+?)^\S/ism;
- addbugtoindex('correspondent',$bug,
- map {lc($_->address)} getparsedaddrs($from)
- );
- }
+ my $log = Debbugs::Log->new(bug_num => $bug);
+ my @correspondents;
+ while (my $record = $log->read_record()) {
+ next unless $record->{type} eq 'incoming-recv';
+ # we use a regex here, because a full mime parse will be slow.
+ my ($from) = $record->{text} =~ /^From:\s+(.+?)^\S/ism;
+ push @correspondents, map {lc($_->address)} getparsedaddrs($from);
+ }
+ addbugtoindex('correspondent',$bug,@correspondents) if @correspondents;
};
if ($@) {
print STDERR "Problem dealing with log of $bug: $@";
use MIME::Parser;
use Debbugs::MIME qw(decode_rfc1522 create_mime_message getmailbody);
-use Debbugs::Mail qw(send_mail_message encode_headers);
+use Debbugs::Mail qw(send_mail_message encode_headers get_addresses);
use Debbugs::Packages qw(getpkgsrc);
use Debbugs::User qw(read_usertags write_usertags);
use Debbugs::Common qw(:lock get_hashname);
{
my $bfound;
($bfound, $data)= &lockreadbugmerge($tryref);
- if ($bfound) {
+ if ($bfound and not $data->{archived}) {
$ref= $tryref;
} else {
&sendmessage(create_mime_message(
References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
Precedence => 'bulk',
"X-$gProject-PR-Message" => 'error',
- ],message_body_template('process_unknown_bug_number',
+ ],message_body_template('mail/process_unknown_bug_number',
{subject => $subject,
date => $header{date},
baddress => $baddress,
To => "$data->{originator}",
Subject => "$gBug#$ref closed by $markedby ($header{'subject'})",
"Message-ID" => "<handler.$ref.$nn.notifdone\@$gEmailDomain>",
- "In-Reply-To" => "$data->{msgid}",
- References => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
+ (defined $data->{msgid})?("In-Reply-To" => $data->{msgid}):(),
+ References => join(' ',grep {defined $_} ($header{'message-id'},$data->{msgid})),
"X-$gProject-PR-Message" => "they-closed $ref",
"X-$gProject-PR-Package" => "$data->{package}",
"X-$gProject-PR-Keywords" => "$data->{keywords}",
$data->{fixed_versions} = [];
if (defined $pheader{source}) {
- $data->{package} = $pheader{source};
+ # source packages are identified by the src: prefix
+ $data->{package} = 'src:'.$pheader{source};
} elsif (defined $pheader{package}) {
$data->{package} = $pheader{package};
} elsif (defined $config{default_package}) {
my $xcchdr= $header{ 'x-debbugs-cc' } || '';
if ($xcchdr =~ m/\S/) {
- push(@resentccs,$xcchdr);
+ push(@resentccs,get_addresses($xcchdr));
$resentccexplain.= fill_template('mail/xdebbugscc',
{xcchdr => $xcchdr},
);
use Debbugs::Log qw(:misc);
use Debbugs::Text qw(:templates);
+use Scalar::Util qw(looks_like_number);
+
+use List::Util qw(first);
+
use Mail::RFC822::Address;
chdir($config{spool_dir}) or
die "Unable to create new IO::Scalar";
print {$transcript} "Processing commands for $controlrequestaddr:\n\n";
-# debug level
+
my $dl = 0;
+my %affected_packages;
+my %recipients;
+# this is the hashref which is passed to all control calls
+my %limit = ();
+
+
+my @common_control_options =
+ (($dl > 0 ? (debug => $transcript):()),
+ transcript => $transcript,
+ requester => $header{from},
+ request_addr => $controlrequestaddr,
+ request_msgid => $header{'message-id'},
+ request_subject => $header{subject},
+ request_nn => $nn,
+ request_replyto => $replyto,
+ message => \@log,
+ affected_packages => \%affected_packages,
+ recipients => \%recipients,
+ limit => \%limit,
+ );
+
my $state= 'idle';
my $lowstate= 'idle';
my $mergelowstate= 'idle';
our $action;
-# recipients of mail
-my %recipients;
-# affected_packages
-my %affected_packages;
my $ok = 0;
my $unknowns = 0;
my $procline=0;
print {$transcript} "> $_\n";
next if m/^\s*\#/;
$action= '';
- if (m/^stop\s*$/i || m/^quit\s*$/i || m/^--\s*$/ || m/^thank(?:s|\s*you)?\s*$/i || m/^kthxbye\s*$/i) {
+ if (m/^(?:stop|quit|--|thank(?:s|\s*you)?|kthxbye)\.*\s*$/i) {
print {$transcript} "Stopping processing here.\n\n";
last;
} elsif (m/^debug\s+(\d+)$/i && $1 >= 0 && $1 <= 1000) {
} elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) {
$ok++;
my $catname = $1;
- my $hidden = ($2 ne "");
+ my $hidden = (defined $2 and $2 ne "");
my $prefix = "";
my @cats;
push @ords, "$ord DEF";
$catsec--;
}
- @ords = sort { my ($a1, $a2, $b1, $b2) = split / /, "$a $b";
- $a1 <=> $b1 || $a2 <=> $b2; } @ords;
+ @ords = sort {
+ my ($a1, $a2, $b1, $b2) = split / /, "$a $b";
+ ((looks_like_number($a1) and looks_like_number($a2))?$a1 <=> $b1:$a1 cmp $b1) ||
+ ((looks_like_number($a2) and looks_like_number($b2))?$a2 <=> $b2:$a2 cmp $b2);
+ } @ords;
$cats[-1]->{"ord"} = [map { m/^.* (\S+)/; $1 eq "DEF" ? $catsec + 1 : $1 } @ords];
} elsif ($o eq "*") {
$catsec = 0;
} elsif (m/^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/i) {
$ok++;
$ref= $1;
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
$bug_affected{$ref}=1;
my $version= $2;
if (&setbug) {
} while (&getnextbug);
}
}
- } elsif (m/^reassign\s+\#?(-?\d+)\s+(\S+)(?:\s+(\d.*))?$/i) {
+ } elsif (m/^reassign\s+\#?(-?\d+)\s+ # bug and command
+ (?:(?:((?:src:|source:)?$config{package_name_re}) # new package
+ (?:\s+((?:$config{package_name_re}\/)?
+ $config{package_version_re}))?)| # optional version
+ ((?:src:|source:)?$config{package_name_re} # multiple package form
+ (?:\s*\,\s*(?:src:|source:)?$config{package_name_re})+))
+ \s*$/xi) {
$ok++;
$ref= $1;
- my $newpackage= $2;
+ my @new_packages;
+ if (not defined $2) {
+ push @new_packages, split /\s*\,\s*/,$4;
+ }
+ else {
+ push @new_packages, $2;
+ }
+ @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages;
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
$bug_affected{$ref}=1;
my $version= $3;
- $newpackage =~ y/A-Z/a-z/;
- if (&setbug) {
- if (length($data->{package})) {
- $action= "$gBug reassigned from package \`$data->{package}'".
- " to \`$newpackage'.";
- } else {
- $action= "$gBug assigned to package \`$newpackage'.";
- }
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- $data->{package}= $newpackage;
- $data->{found_versions}= [];
- $data->{fixed_versions}= [];
- # TODO: what if $newpackage is a source package?
- addfoundversions($data, $data->{package}, $version, 'binary');
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- } while (&getnextbug);
- }
- } elsif (m/^reopen\s+\#?(-?\d+)$/i ? ($noriginator='', 1) :
- m/^reopen\s+\#?(-?\d+)\s+\=$/i ? ($noriginator='', 1) :
- m/^reopen\s+\#?(-?\d+)\s+\!$/i ? ($noriginator=$replyto, 1) :
- m/^reopen\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($noriginator=$2, 1) : 0) {
+ eval {
+ set_package(@common_control_options,
+ bug => $ref,
+ package => \@new_packages,
+ );
+ # if there is a version passed, we make an internal call
+ # to set_found
+ if (defined($version) && length $version) {
+ set_found(@common_control_options,
+ bug => $ref,
+ version => $version,
+ );
+ }
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
+ }
+ } elsif (m/^reopen\s+\#?(-?\d+)(?:\s+([\=\!]|(?:\S.*\S)))?$/i) {
$ok++;
$ref= $1;
- $bug_affected{$ref}=1;
- if (&setbug) {
- if (@{$data->{fixed_versions}}) {
- print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\nyou may need to use 'found' to remove fixed versions.\n";
- }
- if (!length($data->{done})) {
- print {$transcript} "$gBug is already open, cannot reopen.\n\n";
- &nochangebug;
- } else {
- $action=
- $noriginator eq '' ? "$gBug reopened, originator not changed." :
- "$gBug reopened, originator set to $noriginator.";
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- $data->{originator}= $noriginator eq '' ? $data->{originator} : $noriginator;
- $data->{fixed_versions}= [];
- $data->{done}= '';
- } while (&getnextbug);
- }
- }
- } elsif (m{^found\s+\#?(-?\d+)
+ $bug_affected{$ref}=1;
+ my $new_submitter = $2;
+ if (defined $new_submitter) {
+ if ($new_submitter eq '=') {
+ undef $new_submitter;
+ }
+ elsif ($new_submitter eq '!') {
+ $new_submitter = $replyto;
+ }
+ }
+ eval {
+ reopen(@common_control_options,
+ bug => $ref,
+ submitter => $new_submitter,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to reopen $ref: ".cleanup_eval_fail($@,$debug)."\n";
+ }
+ } elsif (m{^(?:(?i)found)\s+\#?(-?\d+)
(?:\s+((?:$config{package_name_re}\/)?
- $config{package_version_re}))?$}ix) {
+ $config{package_version_re}
+ # allow for multiple packages
+ (?:\s*,\s*(?:$config{package_name_re}\/)?
+ $config{package_version_re})*)
+ )?$}x) {
$ok++;
$ref= $1;
- my $version= $2;
- if (&setbug) {
- if (!length($data->{done}) and not defined($version)) {
- print {$transcript} "$gBug is already open, cannot reopen.\n\n";
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
+ my @versions;
+ if (defined $2) {
+ @versions = split /\s*,\s*/,$2;
+ eval {
+ set_found(@common_control_options,
+ bug => $ref,
+ found => \@versions,
+ add => 1,
+ );
+ };
+ if ($@) {
$errors++;
- &nochangebug;
- } else {
- $action=
- defined($version) ?
- "$gBug marked as found in version $version." :
- "$gBug reopened.";
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- # 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
- if (defined $version) {
- my ($version_only) = $version =~ m{([^/]+)$};
- addfoundversions($data, $data->{package}, $version, 'binary');
- my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
- map {s{.+/}{}; $_;} @{$data->{fixed_versions}};
- if (not @fixed_order or (Debbugs::Versions::Dpkg::vercmp($version_only,$fixed_order[-1]) >= 0)) {
- $action = "$gBug marked as found in version $version and reopened."
- if length $data->{done};
- $data->{done} = '';
- }
- } else {
- # Versionless found; assume old-style "not fixed at
- # all".
- $data->{fixed_versions} = [];
- $data->{done} = '';
- }
- } while (&getnextbug);
- }
- }
- } elsif (m[^notfound\s+\#?(-?\d+)\s+
- ((?:$config{package_name_re}\/)?
- \S+)\s*$]ix) {
+ print {$transcript} "Failed to add found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
+ }
+ }
+ else {
+ eval {
+ set_fixed(@common_control_options,
+ bug => $ref,
+ fixed => [],
+ reopen => 1,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n";
+ }
+ }
+ }
+ elsif (m{^(?:(?i)notfound)\s+\#?(-?\d+)
+ \s+((?:$config{package_name_re}\/)?
+ $config{package_version_re}
+ # allow for multiple packages
+ (?:\s*,\s*(?:$config{package_name_re}\/)?
+ $config{package_version_re})*
+ )$}x) {
$ok++;
$ref= $1;
- my $version= $2;
- if (&setbug) {
- $action= "$gBug no longer marked as found in version $version.";
- if (length($data->{done})) {
- $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
- }
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- removefoundversions($data, $data->{package}, $version, 'binary');
- } while (&getnextbug);
- }
- }
- elsif (m[^fixed\s+\#?(-?\d+)\s+
- ((?:$config{package_name_re}\/)?
- $config{package_version_re})\s*$]ix) {
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
+ my @versions;
+ @versions = split /\s*,\s*/,$2;
+ eval {
+ set_found(@common_control_options,
+ bug => $ref,
+ found => \@versions,
+ remove => 1,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to remove found on $ref: ".cleanup_eval_fail($@,$debug)."\n";
+ }
+ }
+ elsif (m{^(?:(?i)fixed)\s+\#?(-?\d+)
+ \s+((?:$config{package_name_re}\/)?
+ $config{package_version_re}
+ # allow for multiple packages
+ (?:\s*,\s*(?:$config{package_name_re}\/)?
+ $config{package_version_re})*)
+ \s*$}x) {
$ok++;
$ref= $1;
- my $version= $2;
- if (&setbug) {
- $action=
- defined($version) ?
- "$gBug marked as fixed in version $version." :
- "$gBug reopened.";
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- addfixedversions($data, $data->{package}, $version, 'binary');
- } while (&getnextbug);
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
+ my @versions;
+ @versions = split /\s*,\s*/,$2;
+ eval {
+ set_fixed(@common_control_options,
+ bug => $ref,
+ fixed => \@versions,
+ add => 1,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to add fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
}
- }
- elsif (m[^notfixed\s+\#?(-?\d+)\s+
- ((?:$config{package_name_re}\/)?
- \S+)\s*$]ix) {
+ }
+ elsif (m{^(?:(?i)notfixed)\s+\#?(-?\d+)
+ \s+((?:$config{package_name_re}\/)?
+ $config{package_version_re}
+ # allow for multiple packages
+ (?:\s*,\s*(?:$config{package_name_re}\/)?
+ $config{package_version_re})*)
+ \s*$}x) {
$ok++;
$ref= $1;
- my $version= $2;
- if (&setbug) {
- $action=
- defined($version) ?
- "$gBug no longer marked as fixed in version $version." :
- "$gBug reopened.";
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- removefixedversions($data, $data->{package}, $version, 'binary');
- } while (&getnextbug);
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
+ my @versions;
+ @versions = split /\s*,\s*/,$2;
+ eval {
+ set_fixed(@common_control_options,
+ bug => $ref,
+ fixed => \@versions,
+ remove => 1,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to remove fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n";
}
- }
- elsif (m/^submitter\s+\#?(-?\d+)\s+\!$/i ? ($newsubmitter=$replyto, 1) :
- m/^submitter\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($newsubmitter=$2, 1) : 0) {
+ }
+ elsif (m/^submitter\s+\#?(-?\d+)\s+(\!|\S.*\S)$/i) {
$ok++;
$ref= $1;
$bug_affected{$ref}=1;
- if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
- $ref = $clonebugs{$ref};
- }
- if (not Mail::RFC822::Address::valid($newsubmitter)) {
- transcript("$newsubmitter is not a valid e-mail address; not changing submitter\n");
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
+ my $newsubmitter = $2 eq '!' ? $replyto : $2;
+ if (not Mail::RFC822::Address::valid($newsubmitter)) {
+ print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n";
$errors++;
}
- elsif (&getbug) {
- if (&checkpkglimit) {
- &foundbug;
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- $oldsubmitter= $data->{originator};
- $data->{originator}= $newsubmitter;
- $action= "Changed $gBug submitter from $oldsubmitter to $newsubmitter.";
- &savebug;
- print {$transcript} "$action\n";
- if (length($data->{done})) {
- print {$transcript} "(By the way, that $gBug is currently marked as done.)\n";
- }
- print {$transcript} "\n";
- $message= <<END;
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $oldsubmitter
-Subject: $gBug#$ref submitter address changed
- ($header{'subject'})
-References: $header{'message-id'} $data->{msgid}
-In-Reply-To: $data->{msgid}
-Message-ID: <handler.$ref.$nn.newsubmitter.$midix\@$gEmailDomain>
-Reply-To: $ref\@$gEmailDomain
-X-$gProject-PR-Message: submitter-changed $ref
-
-The submitter address recorded for your $gBug report
-#$ref: $data->{subject}
-has been changed.
-
-The old submitter address for this report was
-$oldsubmitter.
-The new submitter address is
-$newsubmitter.
-
-This change was made by
-$replyto.
-If it was incorrect, please contact them directly.
-
-$gMaintainer
-(administrator, $gProject $gBugs database)
-
-END
- &sendmailmessage($message,$oldsubmitter);
- } else {
- &cancelbug;
- }
- } else {
- ¬foundbug;
+ else {
+ eval {
+ set_submitter(@common_control_options,
+ bug => $ref,
+ submitter => $newsubmitter,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to set submitter on $ref: ".cleanup_eval_fail($@,$debug)."\n";
+ }
}
} elsif (m/^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/i) {
$ok++;
$ref= $1;
- my $whereto= $2;
- $bug_affected{$ref}=1;
- if (&setbug) {
- if (length($data->{forwarded})) {
- $action= "Forwarded-to-address changed from $data->{forwarded} to $whereto.";
- } else {
- $action= "Noted your statement that $gBug has been forwarded to $whereto.";
- }
- if (length($data->{done})) {
- $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
- }
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- actions_taken => {forwarded => 1},
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- $data->{forwarded}= $whereto;
- } while (&getnextbug);
- }
+ my $forward_to= $2;
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
+ $bug_affected{$ref} = 1;
+ eval {
+ set_forwarded(@common_control_options,
+ bug => $ref,
+ forwarded => $forward_to,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to set the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
+ }
} elsif (m/^notforwarded\s+\#?(-?\d+)$/i) {
$ok++;
$ref= $1;
- $bug_affected{$ref}=1;
- if (&setbug) {
- if (!length($data->{forwarded})) {
- print {$transcript} "$gBug is not marked as having been forwarded.\n\n";
- &nochangebug;
- } else {
- $action= "Removed annotation that $gBug had been forwarded to $data->{forwarded}.";
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- $data->{forwarded}= '';
- } while (&getnextbug);
- }
- }
- } elsif (m/^severity\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i ||
- m/^priority\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i) {
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
+ $bug_affected{$ref} = 1;
+ eval {
+ set_forwarded(@common_control_options,
+ bug => $ref,
+ forwarded => undef,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to clear the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n";
+ }
+ } elsif (m/^(?:severity|priority)\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i) {
$ok++;
$ref= $1;
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
$bug_affected{$ref}=1;
my $newseverity= $2;
- if (!grep($_ eq $newseverity, @gSeverityList, "$gDefaultSeverity")) {
- print {$transcript} "Severity level \`$newseverity' is not known.\n".
- "Recognized are: $gShowSeverities.\n\n";
- $errors++;
- } elsif (exists $gObsoleteSeverities{$newseverity}) {
+ if (exists $gObsoleteSeverities{$newseverity}) {
print {$transcript} "Severity level \`$newseverity' is obsolete. " .
"Use $gObsoleteSeverities{$newseverity} instead.\n\n";
$errors++;
- } elsif (&setbug) {
- my $printseverity= $data->{severity};
- $printseverity= "$gDefaultSeverity" if $printseverity eq '';
- $action= "Severity set to \`$newseverity' from \`$printseverity'";
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- if (defined $gStrongList and isstrongseverity($newseverity)) {
- addbcc("$gStrongList\@$gListDomain");
- }
- $data->{severity}= $newseverity;
- } while (&getnextbug);
- }
- } elsif (m/^tags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
+ } elsif (not defined first {$_ eq $newseverity}
+ (@gSeverityList, "$gDefaultSeverity")) {
+ print {$transcript} "Severity level \`$newseverity' is not known.\n".
+ "Recognized are: $gShowSeverities.\n\n";
+ $errors++;
+ } else {
+ eval {
+ set_severity(@common_control_options,
+ bug => $ref,
+ severity => $newseverity,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: ".cleanup_eval_fail($@,$debug)."\n";
+ }
+ }
+ } elsif (m/^tags?\s+\#?(-?\d+)\s+(\S.*)$/i) {
$ok++;
$ref = $1;
- my $addsubcode = $3;
- my $tags = $4;
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
$bug_affected{$ref}=1;
- my $addsub = "add";
- if (defined $addsubcode) {
- $addsub = "sub" if ($addsubcode eq "-");
- $addsub = "add" if ($addsubcode eq "+");
- $addsub = "set" if ($addsubcode eq "=");
- }
- my @okaytags = ();
- my @badtags = ();
- foreach my $t (split /[\s,]+/, $tags) {
- if (!grep($_ eq $t, @gTags)) {
- push @badtags, $t;
- } else {
- push @okaytags, $t;
+ my $tags = $2;
+ my @tags = split /[\s,]+/, $tags;
+ # this is an array of hashrefs which contain two elements, the
+ # first of which is the array of tags, the second is the
+ # option to pass to set_tags (we use a hashref here to make it
+ # more obvious what is happening)
+ my @tag_operations = {tags => [],
+ option => []
+ };
+ my $alter_type = '=';
+ my @badtags;
+ for my $tag (@tags) {
+ if ($tag =~ /^[=+-]$/) {
+ if ($tag eq '=') {
+ @tag_operations = {tags => [],
+ option => [],
+ };
+ }
+ elsif ($tag eq '-') {
+ push @tag_operations,
+ {tags => [],
+ option => [remove => 1],
+ };
+ }
+ elsif ($tag eq '+') {
+ push @tag_operations,
+ {tags => [],
+ option => [add => 1]
+ };
+ }
+ next;
+ }
+ if (not defined first {$_ eq $tag} @{$config{tags}}) {
+ push @badtags, $tag;
+ next;
}
+ push @{$tag_operations[-1]{tags}},$tag;
}
if (@badtags) {
print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
"Recognized are: ".join(' ', @gTags).".\n\n";
$errors++;
}
- if (&setbug) {
- if ($data->{keywords} eq '') {
- print {$transcript} "There were no tags set.\n";
- } else {
- print {$transcript} "Tags were: $data->{keywords}\n";
- }
- if ($addsub eq "set") {
- $action= "Tags set to: " . join(", ", @okaytags);
- } elsif ($addsub eq "add") {
- $action= "Tags added: " . join(", ", @okaytags);
- } elsif ($addsub eq "sub") {
- $action= "Tags removed: " . join(", ", @okaytags);
+ eval {
+ for my $operation (@tag_operations) {
+ set_tags(@common_control_options,
+ bug => $ref,
+ tags => [@{$operation->{$tags}}],
+ warn_on_bad_tags => 0, # don't warn on bad tags,
+ # 'cause we do that above
+ @{$operation->{option}},
+ );
}
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- $data->{keywords} = '' if ($addsub eq "set");
- # Allow removing obsolete tags.
- if ($addsub eq "sub") {
- foreach my $t (@badtags) {
- $data->{keywords} = join ' ', grep $_ ne $t,
- split ' ', $data->{keywords};
- }
- }
- # Now process all other additions and subtractions.
- foreach my $t (@okaytags) {
- $data->{keywords} = join ' ', grep $_ ne $t,
- split ' ', $data->{keywords};
- $data->{keywords} = "$t $data->{keywords}" unless($addsub eq "sub");
- }
- $data->{keywords} =~ s/\s*$//;
- } while (&getnextbug);
+ };
+ if ($@) {
+ # we intentionally have two errors here if there is a bad
+ # tag and the above fails for some reason
+ $errors++;
+ print {$transcript} "Failed to alter tags of $config{bug} $ref: ".cleanup_eval_fail($@,$debug)."\n";
}
- } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(by|with)\s+(\S.*)?$/i) {
+ } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(?:by|with)\s+(\S.*)?$/i) {
$ok++;
- my $bugnum = $2; my $blockers = $4;
- my $addsub = "add";
- $addsub = "sub" if (defined $1 and $1 eq "un");
- if ($bugnum =~ m/^-\d+$/ && defined $clonebugs{$bugnum}) {
- $bugnum = $clonebugs{$bugnum};
- }
-
- my @okayblockers;
- my @badblockers;
- foreach my $b (split /[\s,]+/, $blockers) {
- $b=~s/^\#//;
- if ($b=~/[0-9]+/) {
- $ref=$b;
- if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
- $ref = $clonebugs{$ref};
- }
- if (&getbug) {
- &foundbug;
- push @okayblockers, $ref;
-
- # add to the list all bugs that are merged with $b,
- # because all of their data must be kept in sync
- my @thisbugmergelist= split(/ /,$data->{mergedwith});
- &cancelbug;
-
- foreach $ref (@thisbugmergelist) {
- if (&getbug) {
- push @okayblockers, $ref;
- &cancelbug;
- }
- }
- }
- else {
- ¬foundbug;
- push @badblockers, $ref;
- }
- }
- else {
- push @badblockers, $b;
- }
- }
- if (@badblockers) {
- print {$transcript} "Unknown blocking bug/s: ".join(', ', @badblockers).".\n";
+ $ref= $2;
+ my $add_remove = defined $1 && $1 eq 'un';
+ my @blockers = split /[\s,]+/, $3;
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
+ $bug_affected{$ref} = 1;
+ eval {
+ set_blocks(@common_control_options,
+ bug => $ref,
+ block => \@blockers,
+ $add_remove ? (remove => 1):(add => 1),
+ );
+ };
+ if ($@) {
$errors++;
- }
-
- $ref=$bugnum;
- if (&setbug) {
- if ($data->{blockedby} eq '') {
- print {$transcript} "Was not blocked by any bugs.\n";
- } else {
- print {$transcript} "Was blocked by: $data->{blockedby}\n";
- }
- if ($addsub eq "set") {
- $action= "Blocking bugs of $bugnum set to: " . join(", ", @okayblockers);
- } elsif ($addsub eq "add") {
- $action= "Blocking bugs of $bugnum added: " . join(", ", @okayblockers);
- } elsif ($addsub eq "sub") {
- $action= "Blocking bugs of $bugnum removed: " . join(", ", @okayblockers);
- }
- my %removedblocks;
- my %addedblocks;
- do {
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- my @oldblockerlist = split ' ', $data->{blockedby};
- $data->{blockedby} = '' if ($addsub eq "set");
- foreach my $b (@okayblockers) {
- $data->{blockedby} = manipset($data->{blockedby}, $b,
- ($addsub ne "sub"));
- }
-
- foreach my $b (@oldblockerlist) {
- if (! grep { $_ eq $b } split ' ', $data->{blockedby}) {
- push @{$removedblocks{$b}}, $ref;
- }
- }
- foreach my $b (split ' ', $data->{blockedby}) {
- if (! grep { $_ eq $b } @oldblockerlist) {
- push @{$addedblocks{$b}}, $ref;
- }
- }
- } while (&getnextbug);
-
- # Now that the blockedby data is updated, change blocks data
- # to match the changes.
- foreach $ref (keys %addedblocks) {
- if (&getbug) {
- foreach my $b (@{$addedblocks{$ref}}) {
- $data->{blocks} = manipset($data->{blocks}, $b, 1);
- }
- &savebug;
- }
- }
- foreach $ref (keys %removedblocks) {
- if (&getbug) {
- foreach my $b (@{$removedblocks{$ref}}) {
- $data->{blocks} = manipset($data->{blocks}, $b, 0);
- }
- &savebug;
- }
- }
+ print {$transcript} "Failed to set blocking bugs of $ref: ".cleanup_eval_fail($@,$debug)."\n";
}
} elsif (m/^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/i) {
$ok++;
$ref= $1; my $newtitle= $2;
- $bug_affected{$ref}=1;
- if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
- $ref = $clonebugs{$ref};
+ $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
+ $bug_affected{$ref} = 1;
+ eval {
+ set_title(@common_control_options,
+ bug => $ref,
+ title => $newtitle,
+ );
+ };
+ if ($@) {
+ $errors++;
+ print {$transcript} "Failed to set the title of $ref: ".cleanup_eval_fail($@,$debug)."\n";
}
- if (&getbug) {
- if (&checkpkglimit) {
- &foundbug;
- $affected_packages{$data->{package}} = 1;
- add_recipients(data => $data,
- recipients => \%recipients,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- );
- my $oldtitle = $data->{subject};
- $data->{subject}= $newtitle;
- $action= "Changed $gBug title to `$newtitle' from `$oldtitle'.";
- &savebug;
- print {$transcript} "$action\n";
- if (length($data->{done})) {
- print {$transcript} "(By the way, that $gBug is currently marked as done.)\n";
- }
- print {$transcript} "\n";
- } else {
- &cancelbug;
- }
- } else {
- ¬foundbug;
- }
} elsif (m/^unmerge\s+\#?(-?\d+)$/i) {
$ok++;
$ref= $1;
my @pkgs = split /\s+/, $1;
if (scalar(@pkgs) > 0) {
%limit_pkgs = map { ($_, 1) } @pkgs;
+ $limit{package} = [@pkgs];
print {$transcript} "Ignoring bugs not assigned to: " .
join(" ", keys(%limit_pkgs)) . "\n\n";
} else {
%limit_pkgs = ();
print {$transcript} "Not ignoring any bugs.\n\n";
}
+ } elsif (m/^limit\:?\s+(\S.*\S)\s*$/) {
+ $ok++;
+ my ($field,@options) = split /\s+/, $1;
+ $field = lc($field);
+ if ($field =~ /^(?:clear|unset|blank)$/) {
+ %limit = ();
+ print {$transcript} "Limit cleared.\n\n";
+ }
+ elsif (exists $Debbugs::Status::fields{$field} ) {
+ # %limit can actually contain regexes, but because they're
+ # not evaluated in Safe, DO NOT allow them through without
+ # fixing this.
+ $limit{$field} = [@options];
+ print {$transcript} "Limiting to bugs with field '$field' containing at least one of ".join(', ',map {qq('$_')} @options)."\n";
+ print {$transcript} "Limit currently set to ";
+ for my $limit_field (keys %limit) {
+ print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @options)."\n";
+ }
+ print {$transcript} "\n";
+ }
+ else {
+ print {$transcript} "Limit key $field not understood. Stopping processing here.\n\n";
+ $errors++;
+ last;
+ }
} elsif (m/^affects?\s+\#?(-?\d+)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/i) {
$ok++;
$ref = $1;
$ref = $clonebugs{$ref} if exists $clonebugs{$ref};
$bug_affected{$ref} = 1;
eval {
- affects(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- recipients => \%recipients,
+ affects(@common_control_options,
+ bug => $ref,
packages => [splitpackages($3)],
($add_remove eq '+'?(add => 1):()),
($add_remove eq '-'?(remove => 1):()),
};
if ($@) {
$errors++;
- print {$transcript} "Failed to give $ref a summary: $@";
+ print {$transcript} "Failed to mark $ref as affecting package(s): ".cleanup_eval_fail($@,$debug)."\n";
}
} elsif (m/^summary\s+\#?(-?\d+)\s*(\d+|)\s*$/i) {
$ref = $clonebugs{$ref} if exists $clonebugs{$ref};
$bug_affected{$ref} = 1;
eval {
- summary(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- recipients => \%recipients,
+ summary(@common_control_options,
+ bug => $ref,
summary => $summary_msg,
);
};
if ($@) {
$errors++;
- print {$transcript} "Failed to give $ref a summary: $@";
+ print {$transcript} "Failed to give $ref a summary: ".cleanup_eval_fail($@,$debug)."\n";
}
} elsif (m/^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/i) {
}
$bug_affected{$ref} = 1;
eval {
- owner(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- recipients => \%recipients,
+ owner(@common_control_options,
+ bug => $ref,
owner => $newowner,
);
};
if ($@) {
$errors++;
- print {$transcript} "Failed to mark $ref as having an owner: $@";
+ print {$transcript} "Failed to mark $ref as having an owner: ".cleanup_eval_fail($@,$debug)."\n";
}
} elsif (m/^noowner\s+\#?(-?\d+)\s*$/i) {
$ok++;
$ref = $clonebugs{$ref} if exists $clonebugs{$ref};
$bug_affected{$ref} = 1;
eval {
- owner(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- recipients => \%recipients,
+ owner(@common_control_options,
+ bug => $ref,
owner => undef,
);
};
if ($@) {
$errors++;
- print {$transcript} "Failed to mark $ref as not having an owner: $@";
+ print {$transcript} "Failed to mark $ref as not having an owner: ".cleanup_eval_fail($@,$debug)."\n";
}
} elsif (m/^unarchive\s+#?(\d+)$/i) {
$ok++;
$ref = $clonebugs{$ref} if exists $clonebugs{$ref};
$bug_affected{$ref} = 1;
eval {
- bug_unarchive(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
- affected_bugs => \%bug_affected,
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
+ bug_unarchive(@common_control_options,
+ bug => $ref,
recipients => \%recipients,
);
};
$ref = $clonebugs{$ref} if exists $clonebugs{$ref};
$bug_affected{$ref} = 1;
eval {
- bug_archive(bug => $ref,
- transcript => $transcript,
- ($dl > 0 ? (debug => $transcript):()),
+ bug_archive(@common_control_options,
+ bug => $ref,
ignore_time => 1,
archive_unarchived => 0,
- affected_bugs => \%bug_affected,
- requester => $header{from},
- request_addr => $controlrequestaddr,
- message => \@log,
- recipients => \%recipients,
);
};
if ($@) {
sub sendtxthelpraw {
my ($relpath,$description) = @_;
$doc='';
+ if (not -e "$gDocDir/$relpath") {
+ print {$transcript} "Unfortunatly, the help text doesn't exist, so it wasn't sent.\n";
+ warn "Help text $gDocDir/$relpath not found";
+ return;
+ }
open(D,"$gDocDir/$relpath") || die "open doc file $relpath: $!";
while(<D>) { $doc.=$_; }
close(D);
--- /dev/null
+# -*- mode: cperl; -*-
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
--- /dev/null
+# -*- mode: cperl;-*-
+
+use Test::More tests => 6;
+
+use warnings;
+use strict;
+
+use utf8;
+use Encode;
+
+use_ok('Debbugs::Status');
+
+my $data = {package => 'foo, bar, baz',
+ blocks => '1 2 3',
+ blockedby => '',
+ tags => 'foo, bar , baz',
+ };
+
+my @temp = Debbugs::Status::split_status_fields($data);
+is_deeply($temp[0]{package},[qw(foo bar baz)],
+ 'split_status_fields splits packages properly',
+ );
+is_deeply($temp[0]{blocks},[qw(1 2 3)],
+ 'split_status_fields splits blocks properly',
+ );
+is_deeply($temp[0]{blockedby},[],
+ 'split_status_fields handles empty fields properly',
+ );
+is_deeply($temp[0]{tags},[qw(foo bar baz)],
+ 'split_status_fields splits tags properly',
+ );
+my $temp = Debbugs::Status::split_status_fields($data);
+is_deeply(Debbugs::Status::split_status_fields($temp),$temp,
+ 'recursively calling split_status_fields returns the same thing');
# -*- mode: cperl;-*-
# $Id: 05_mail.t,v 1.1 2005/08/17 21:46:17 don Exp $
-use Test::More tests => 96;
+use Test::More tests => 102;
use warnings;
use strict;
# sent out. 1) ack to submitter 2) mail to maintainer
# This keeps track of the previous size of the sendmail directory
-my $SD_SIZE_PREV = 0;
-my $SD_SIZE_NOW = dirsize($sendmail_dir);
-ok($SD_SIZE_NOW-$SD_SIZE_PREV >= 2,'submit messages appear to have been sent out properly');
-$SD_SIZE_PREV=$SD_SIZE_NOW;
+my $SD_SIZE = 0;
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,2,
+ $sendmail_dir,
+ 'submit messages appear to have been sent out properly',
+ );
+
# now send a message to the bug
This is a silly bug
EOF
-$SD_SIZE_NOW = dirsize($sendmail_dir);
-ok($SD_SIZE_NOW-$SD_SIZE_PREV >= 2,'1@bugs.something messages appear to have been sent out properly');
-$SD_SIZE_PREV=$SD_SIZE_NOW;
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,2,
+ $sendmail_dir,
+ '1@bugs.something messages appear to have been sent out properly');
# just check to see that control doesn't explode
send_message(to => 'control@bugs.something',
thanks
EOF
-$SD_SIZE_NOW = dirsize($sendmail_dir);
-ok($SD_SIZE_NOW-$SD_SIZE_PREV >= 1,'control@bugs.something messages appear to have been sent out properly');
-$SD_SIZE_PREV=$SD_SIZE_NOW;
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,1,
+ $sendmail_dir,
+ 'control@bugs.something messages appear to have been sent out properly');
# now we need to check to make sure the control message was processed without errors
ok(system('sh','-c','find '.$sendmail_dir.q( -type f | xargs grep -q "Subject: Processed: Munging a bug")) == 0,
'control@bugs.something message was parsed without errors');
# now we're going to go through and methododically test all of the control commands.
my @control_commands =
- (severity_wishlist => {command => 'severity',
+ (
+ severity_wishlist => {command => 'severity',
value => 'wishlist',
status_key => 'severity',
status_value => 'wishlist',
},
- reassign_bar => {command => 'reassign',
- value => 'bar',
- status_key => 'package',
- status_value => 'bar',
- },
+ reassign_bar_baz => {command => 'reassign',
+ value => 'bar,baz',
+ status_key => 'package',
+ status_value => 'bar,baz',
+ },
reassign_foo => {command => 'reassign',
value => 'foo',
status_key => 'package',
status_key => 'mergedwith',
status_value => '2',
},
+ unmerge => {command => 'unmerge',
+ value => '',
+ status_key => 'mergedwith',
+ status_value => '',
+ },
+ block => {command => 'block',
+ value => ' with 2',
+ status_key => 'blockedby',
+ status_value => '2',
+ },
summary => {command => 'summary',
value => '5',
status_key => 'summary',
thanks
EOF
;
- $SD_SIZE_NOW = dirsize($sendmail_dir);
- ok($SD_SIZE_NOW-$SD_SIZE_PREV >= 1,'control@bugs.something messages appear to have been sent out properly');
- $SD_SIZE_PREV=$SD_SIZE_NOW;
+ $SD_SIZE =
+ num_messages_sent($SD_SIZE,1,
+ $sendmail_dir,
+ 'control@bugs.something messages appear to have been sent out properly');
# now we need to check to make sure the control message was processed without errors
ok(system('sh','-c','find '.$sendmail_dir.q( -type f | xargs grep -q "Subject: Processed: Munging a bug with $command")) == 0,
'control@bugs.something'. "$command message was parsed without errors");
thanks
EOF
;
-$SD_SIZE_NOW = dirsize($sendmail_dir);
-ok($SD_SIZE_NOW-$SD_SIZE_PREV >= 1,'control@bugs.something messages appear to have been sent out properly');
-$SD_SIZE_PREV=$SD_SIZE_NOW;
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,1,
+ $sendmail_dir,
+ 'control@bugs.something messages appear to have been sent out properly');
# now we need to check to make sure the control message was processed without errors
ok(system('sh','-c','find '.$sendmail_dir.q( -type f | xargs grep -q "Subject: Processed: Munging a bug with unarchivearchive")) == 0,
'control@bugs.something'. "unarchive/archive message was parsed without errors");
--- /dev/null
+# -*- mode: cperl; -*-
+
+use Test::More tests => 4;
+
+use warnings;
+use strict;
+
+# Here, we're going to shoot messages through a set of things that can
+# happen.
+
+# First, we're going to send mesages to receive.
+# To do so, we'll first send a message to submit,
+# then send messages to the newly created bugnumber.
+
+use IO::File;
+use File::Temp qw(tempdir);
+use Cwd qw(getcwd);
+use Debbugs::MIME qw(create_mime_message);
+use File::Basename qw(dirname basename);
+# The test functions are placed here to make things easier
+use lib qw(t/lib);
+use DebbugsTest qw(:all);
+use Data::Dumper;
+
+# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
+$SIG{CHLD} = sub {};
+my %config;
+eval {
+ %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
+};
+if ($@) {
+ BAIL_OUT($@);
+}
+
+my $sendmail_dir = $config{sendmail_dir};
+my $spool_dir = $config{spool_dir};
+my $config_dir = $config{config_dir};
+
+END{
+ if ($ENV{DEBUG}) {
+ diag("spool_dir: $spool_dir\n");
+ diag("config_dir: $config_dir\n");
+ diag("sendmail_dir: $sendmail_dir\n");
+ }
+}
+
+# We're going to use create mime message to create these messages, and
+# then just send them to receive.
+
+send_message(to=>'submit@bugs.something',
+ headers => [To => 'submit@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Submiting a bug',
+ ],
+ body => <<EOF) or fail('Unable to send message');
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+
+my $SD_SIZE = dirsize($sendmail_dir);
+send_message(to => 'control@bugs.something',
+ headers => [To => 'control@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => "Munging a bug with limit_package_bar",
+ ],
+ body => <<EOF) or fail 'message to control@bugs.something failed';
+debug 10
+limit package bar
+severity 1 wishlist
+thanks
+EOF
+
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,1,
+ $sendmail_dir,
+ 'control@bugs.something messages appear to have been sent out properly');
+
+# make sure this fails
+ok(system('sh','-c','find '.$sendmail_dir.q( -type f | xargs grep -q "Subject: Processed (with 1 errors): Munging a bug with limit_package_bar")) == 0,
+ 'control@bugs.something'. "limit message failed with 1 error");
+
+send_message(to => 'control@bugs.something',
+ headers => [To => 'control@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => "Munging a bug with limit_package_foo",
+ ],
+ body => <<EOF) or fail 'message to control@bugs.something failed';
+debug 10
+limit package foo
+severity 1 wishlist
+thanks
+EOF
+
+$SD_SIZE =
+ num_messages_sent($SD_SIZE,1,
+ $sendmail_dir,
+ 'control@bugs.something messages appear to have been sent out properly');
+
+# make sure this fails
+ok(system('sh','-c','find '.$sendmail_dir.q( -type f | xargs grep -q "Subject: Processed: Munging a bug with limit_package_foo")) == 0,
+ 'control@bugs.something'. "limit message succeeded with no errors");
+
use File::Basename qw(dirname basename);
use IPC::Open3;
use IO::Handle;
+use Test::More;
use Params::Validate qw(validate_with :types);
@EXPORT = ();
%EXPORT_TAGS = (configuration => [qw(dirsize create_debbugs_configuration send_message)],
+ mail => [qw(num_messages_sent)],
);
@EXPORT_OK = ();
- Exporter::export_ok_tags(qw(configuration));
+ Exporter::export_ok_tags(qw(configuration mail));
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
}
}
+=head2 num_messages_sent
+
+ $SD_SIZE = num_messages_sent($SD_SIZE,2,$sendmail_dir,'2 messages have been sent properly');
+
+Tests to make sure that at least a certain number of messages have
+been sent since the last time this command was run. Usefull to test to
+make sure that mail has been sent.
+
+=cut
+
+sub num_messages_sent {
+ my ($prev_size,$num_messages,$sendmail_dir,$test_name) = @_;
+ my $cur_size = dirsize($sendmail_dir);
+ ## print STDERR "sendmail: $sendmail_dir, want: $num_messages,
+ ## size: $cur_size, prev_size: $prev_size\n";
+ ok($cur_size-$prev_size >= $num_messages, $test_name);
+ return $cur_size;
+}
+
1;
$output .= sprintf qq(<p><a href="%s">Full log</a></p>),html_escape(bug_links(bug=>$bug_num,links_only=>1));
}
else {
- $output .= qq(<p><a href="mailto:$bug_num\@$config{email_domain}">Reply</a> ).
- qq(or <a href="mailto:$bug_num-subscribe\@$config{email_domain}">subscribe</a> ).
+ if (not $status{archived}) {
+ $output .= qq(<p><a href="mailto:$bug_num\@$config{email_domain}">Reply</a> ).
+ qq(or <a href="mailto:$bug_num-subscribe\@$config{email_domain}">subscribe</a> ).
qq(to this bug.</p>\n);
+ }
$output .= qq(<p><a href="javascript:toggle_infmessages();">Toggle useless messages</a></p>);
$output .= sprintf qq(<div class="msgreceived"><p>View this report as an <a href="%s">mbox folder</a>, ).
qq(<a href="%s">status mbox</a>, <a href="%s">maintainer mbox</a></p></div>\n),
<div class="pkginfo">
<p>{if (keys %package > 1) { q(Packages)} else {q(Package)}}:
- {join(q(, ),package_links(package => [map {$_->{package}} values %package],
+ {join(q(, ),package_links(package => [map {$_->{package}} grep {!$_->{is_source}} values %package],
+ source => [map {$_->{source} } grep { $_->{is_source}} values %package],
class => q(submitter),
)
)};
{my $output ='';
for my $package (values %package) {
- $output .= q(Maintainer for ).package_links(package=>$package->{package}).qq( is ).
+ $output .= q(Maintainer for ).package_links($package->{is_source}?(source=>$package->{source}):(package=>$package->{package})).qq( is ).
package_links(maintainer => $package->{maintainer}).qq(; );
- if (exists $package->{source}) {
+ if (exists $package->{source} and not $package->{is_source}) {
$output .= q(Source for ).package_links(package=>$package->{package}).qq( is ).
package_links(source => $package->{source}).qq(. );
}
$output .= qq(<abbr title="fixed versions">☺</abbr>);
}
if (@{$status{blockedby_array}}) {
- $output .= qq(<abbr title="blocked by">â\94«</abbr>);
+ $output .= qq(<abbr title="blocked by">â\99\99</abbr>);
}
if (@{$status{blocks_array}}) {
- $output .= qq(<abbr title="blocks">â\94£</abbr>);
+ $output .= qq(<abbr title="blocks">â\99\94</abbr>);
}
if (length($status{forwarded})) {
$output .= qq(<abbr title="forwarded">↝</abbr>);
if ($status{archived}) {
$output .= qq(<abbr title="archived">♲</abbr>);
}
+ if (length $status{affects}){
+ $output .= qq(<abbr title="affects">☣</abbr>);
+ }
length($output)?$output:' ';
}</span></font>]
- [{package_links(package=>$status{package},options=>\%options,class=>"submitter")}]
+ [{package_links(package=>[split /,/,$status{package}],options=>\%options,class=>"submitter")}]
<a href="{html_escape(bug_links(bug=>$status{bug_num},links_only=>1))}">{html_escape($status{subject})}</a>
<div id="extra_status_{html_escape($status{bug_num})}" class="shortbugstatusextra">
<span>Reported by: {package_links(submitter=>$status{originator})};</span>
Received: (at fakecontrol) by fakecontrolmessage;
To: {$request_addr}
-From: $requester
+From: {$requester}
Subject: Internal Control
Message-Id: {$action}
Date: {$date}
User-Agent: Fakemail v42.6.9
# A New Hope
-# A log time ago, in a galaxy far, far away
+# A long time ago, in a galaxy far, far away
# something happened.
#
# Magically this resulted in the following
has been received.
{ $forwardexplain }{ $resentccexplain }
If you wish to submit further information on this problem, please
-send it to { $refreplyto }, as before.
+send it to { $refreplyto }.
Please do not send mail to {$config{maintainer_email}} unless you wish
to report a problem with the {ucfirst($config{bug})}-tracking system.
-Your message didn't have a Package: line at the start (in the
-pseudo-header following the real mail header), or didn't have a
-pseudo-header at all. Your message has been filed under junk but
-otherwise ignored.
+Your message didn't have a Package: line at the very first line of the
+mail body (part of the pseudo-header), or didn't have a Package: line
+at all. Unfortunatly, this means that your message has been ignored
+completely.
-This makes it much harder for us to categorise and deal with your
-problem report. Please _resubmit_ your report to {$baddress}@{$config{email_domain}}
-and tell us which package the report is on. For help, check out
+Without this information we are unable to categorise or otherwise deal
+with your problem report. Please _resubmit_ your report to
+{$baddress}@{$config{email_domain}} and tell us which package the
+report is for. For help, check out
http://{$config{web_domain}}/Reporting{$config{html_suffix}}.
Your message was dated {$date} and had
and subject {$subject}.
The complete text of it is attached to this message.
-If you need any assistance or explanation please contact {$config{maintainer_email}}.
+If you need any assistance or explanation please contact
+{$config{maintainer_email}} and include the the attached
+message.
+
+If you didn't send the attached message (spam was sent forging your
+from address), we apologize; please disregard this message.
--- /dev/null
+The submitter address recorded for your {$config{bug}} report
+#{$data->{bug_num}}: {$data->{subject}}
+has been changed.
+
+The old submitter address for this report was
+{$old_data->{submitter}}.
+The new submitter address is
+{$data->{submitter}}.
+
+This change was made by
+{$replyto}.
+If it was incorrect, please contact them directly.
projects / debbugs.git / commitdiff