use IO::File;
use Debbugs::Status qw(splitpackages get_bug_status);
use Debbugs::Packages qw(getsrcpkgs getpkgsrc);
-use Debbugs::Common qw(getparsedaddrs package_maintainer getmaintainers make_list);
+use Debbugs::Common qw(getparsedaddrs package_maintainer getmaintainers make_list hash_slice);
use Fcntl qw(O_RDONLY);
use MLDBM qw(DB_File Storable);
- use List::Util qw(first);
+ use List::AllUtils qw(first);
use Carp;
=head2 get_bugs
=cut
+my $_non_search_key_regex = qr/^(bugs|archive|usertags|schema)$/;
+
+my %_get_bugs_common_options =
+ (package => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ src => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ maint => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ submitter => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ severity => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ status => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ tag => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ owner => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ dist => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ correspondent => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ affects => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ function => {type => CODEREF,
+ optional => 1,
+ },
+ bugs => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ archive => {type => BOOLEAN|SCALAR,
+ default => 0,
+ },
+ usertags => {type => HASHREF,
+ optional => 1,
+ },
+ schema => {type => OBJECT,
+ optional => 1,
+ },
+ );
+
+
+my $_get_bugs_options = {%_get_bugs_common_options};
sub get_bugs{
my %param = validate_with(params => \@_,
- spec => {package => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- src => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- maint => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- submitter => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- severity => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- status => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- tag => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- owner => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- dist => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- correspondent => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- affects => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- function => {type => CODEREF,
- optional => 1,
- },
- bugs => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- archive => {type => BOOLEAN|SCALAR,
- default => 0,
- },
- usertags => {type => HASHREF,
- optional => 1,
- },
- },
- );
+ spec => $_get_bugs_options,
+ );
# Normalize options
my %options = %param;
return keys %bugs;
}
# A configuration option will set an array that we'll use here instead.
- for my $routine (qw(Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
+ for my $routine (qw(Debbugs::Bugs::get_bugs_by_db Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
my ($package) = $routine =~ m/^(.+)\:\:/;
eval "use $package;";
if ($@) {
=cut
+
+my $_get_bugs_by_idx_options =
+ {hash_slice(%_get_bugs_common_options,
+ (qw(package submitter severity tag archive),
+ qw(owner src maint bugs correspondent),
+ qw(affects usertags))
+ )
+ };
sub get_bugs_by_idx{
my %param = validate_with(params => \@_,
- spec => {package => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- submitter => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- severity => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- tag => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- archive => {type => BOOLEAN,
- default => 0,
- },
- owner => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- src => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- maint => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- bugs => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- correspondent => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- affects => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- usertags => {type => HASHREF,
- optional => 1,
- },
- },
+ spec => $_get_bugs_by_idx_options
);
my %bugs = ();
delete @param{qw(maint src)};
$param{package} = [@packages];
}
- my $keys = grep {$_ !~ /^(archive|usertags|bugs)$/} keys(%param);
+ my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
die "Need at least 1 key to search by" unless $keys;
my $arc = $param{archive} ? '-arc':'';
my %idx;
- for my $key (grep {$_ !~ /^(archive|usertags|bugs)$/} keys %param) {
+ for my $key (grep {$_ !~ $_non_search_key_regex} keys %param) {
my $index = $key;
$index = 'submitter-email' if $key eq 'submitter';
$index = "$config{spool_dir}/by-${index}${arc}.idx";
}
+=head2 get_bugs_by_db
+
+This routine uses the database to try to speed up
+searches.
+
+
+=cut
+
+my $_get_bugs_by_db_options =
+ {hash_slice(%_get_bugs_common_options,
+ (qw(package submitter severity tag archive),
+ qw(owner src maint bugs correspondent),
+ qw(affects usertags))
+ ),
+ schema => {type => OBJECT,
+ },
+ };
+sub get_bugs_by_db{
+ my %param = validate_with(params => \@_,
+ spec => $_get_bugs_by_db_options,
+ );
+ my %bugs = ();
+
+ my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
+ die "Need at least 1 key to search by" unless $keys;
+ my $rs = $param{schema}->resultset('Bug');
+ if (exists $param{package}) {
+ $rs = $rs->search({-or => {map 'bin_package.'}})
+ }
+ if (exists $param{severity}) {
+ $rs = $rs->search({-or => {map {('severity.severity' => $_)}
+ make_list($param{severity})},
+ },
+ {join => 'severity'},
+ );
+ }
+ for my $key (qw(owner submitter done)) {
+ if (exists $param{$key}) {
+ $rs = $rs->search({-or => {map {("${key}.addr" => $_)}
+ make_list($param{$key})},
+ },
+ {join => $key},
+ );
+ }
+ }
+ if (exists $param{correspondent}) {
+ $rs = $rs->search({-or => {map {('message_correspondents.addr' => $_)}
+ make_list($param{correspondent})},
+ },
+ {join => {correspondent =>
+ {bug_messages =>
+ {message => 'message_correspondents'}}}},
+ );
+ }
+ if (exists $param{affects}) {
+ $rs = $rs->search({-or => {map {('bin_pkg.pkg' => $_,
+ 'src_pkg.pkg' => $_,
+ )}
+ make_list($param{affects}),
+ },
+ },
+ {join => [{bug_affects_binpackages => 'bin_pkg'},
+ {bug_affects_srcpackages => 'src_pkg'},
+ ],
+ },
+ );
+ }
+ if (exists $param{package}) {
+ $rs = $rs->search({-or => {map {('bin_pkg.pkg' => $_)}
+ make_list($param{package})},
+ },
+ {join => {bug_binpackages => 'bin_pkg'}});
+ }
+ if (exists $param{maintainer}) {
+ $rs = $rs->search({-or => {map {(correspondent => $_ eq '' ? undef : $_,
+ correspondent2 => $_ eq '' ? undef : $_,
+ )}
+ make_list($param{maintainer})
+ }
+ },
+ {join => {bug_affects_binpackage =>
+ {bin_pkg =>
+ {bin_ver =>
+ {src_ver =>
+ {maintainer => 'correspondent'}
+ }}},
+ {bug_affects_srcpackage =>
+ {src_pkg =>
+ {src_ver =>
+ {maintainer => 'correspondent'}
+ }}}}
+ }
+ );
+ }
+ if (exists $param{src}) {
+ $rs = $rs->search({-or => {map {('src_pkg.pkg' => $_)}
+ make_list($param{src})},
+ },
+ {join => {bug_srcpackages => 'src_pkg'}});
+ }
+ # tags are very odd, because we must handle usertags.
+ if (exists $param{tag}) {
+ # bugs from usertags which matter
+ my %bugs_matching_usertags;
+ for my $bug (make_list(grep {defined $_ }
+ @{$param{usertags}}{make_list($param{tag})})) {
+ $bugs_matching_usertags{$bug} = 1;
+ }
+ # we want all bugs which either match the tag name given in
+ # param, or have a usertag set which matches one of the tag
+ # names given in param.
+ $rs = $rs->search({-or => {map {('tag.tag' => $_)}
+ make_list($param{tag}),
+ map {('me.id' => $_)}
+ keys %bugs_matching_usertags
+ },
+ },
+ {join => {bug_tags => 'tag'}});
+ }
+ if (exists $param{bugs}) {
+ $rs = $rs->search({-or => {map {('me.id' => $_)}
+ make_list($param{bugs})}
+ });
+ }
+ # handle archive
+ if (defined $param{archive} and $param{archive} ne 'both') {
+ $rs = $rs->search({'me.archived' => $param{archive}});
+ }
+ return $rs->get_column('id')->all();
+}
+
+
=head2 get_bugs_flatfile
This is the fallback search routine. It should be able to complete all
=cut
+my $_get_bugs_flatfile_options =
+ {hash_slice(%_get_bugs_common_options,
+ map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options
+ )
+ };
+
sub get_bugs_flatfile{
my %param = validate_with(params => \@_,
- spec => {package => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- src => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- maint => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- submitter => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- severity => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- status => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- tag => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- owner => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- correspondent => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- affects => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
-# not yet supported
-# dist => {type => SCALAR|ARRAYREF,
-# optional => 1,
-# },
- bugs => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- archive => {type => BOOLEAN,
- default => 1,
- },
- usertags => {type => HASHREF,
- optional => 1,
- },
- function => {type => CODEREF,
- optional => 1,
- },
- },
+ spec => $_get_bugs_flatfile_options
);
my $flatfile;
if ($param{archive}) {
use warnings;
use strict;
+ use utf8;
use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
use Exporter qw(import);
use Params::Validate qw(validate_with :types);
use Digest::MD5 qw(md5_hex);
use Debbugs::Mail qw(get_addresses :reply);
-use Debbugs::MIME qw(decode_rfc1522 create_mime_message);
+use Debbugs::MIME qw(decode_rfc1522 create_mime_message parse_to_mime_entity);
use Debbugs::CGI qw(:url :html :util);
use Debbugs::Common qw(globify_scalar english_join);
use Debbugs::UTF8;
use Encode qw(decode_utf8 encode_utf8);
use URI::Escape qw(uri_escape_utf8);
use Scalar::Util qw(blessed);
+ use List::AllUtils qw(sum);
use File::Temp;
BEGIN{
my $output = globify_scalar($param{output});
my $entity = $param{entity};
my $ref = $param{bug_num};
- my $top = $param{outer};
my $xmessage = $param{msg_num};
my $attachments = $param{attachments};
my $body = $entity->bodyhandle->as_string;
$body = convert_to_utf8($body,$charset//'utf8');
$body = html_escape($body);
+ my $css_class = "message";
# Attempt to deal with format=flowed
if ($content_type =~ m/format\s*=\s*\"?flowed\"?/i) {
$body =~ s{^\ }{}mgo;
# we ignore the other things that you can do with
# flowed e-mails cause they don't really matter.
+ $css_class .= " flowed";
+ }
+
+ # if the message is composed entirely of lines which are separated by
+ # newlines, wrap it. [Allow the signature to have special formatting.]
+ if ($body =~ /^([^\n]+\n\n)*[^\n]*\n?(-- \n.+)*$/s or
+ # if the first 20 lines in the message which have any non-space
+ # characters are larger than 100 characters more often than they
+ # are not, then use CSS to try to impose sensible wrapping
+ sum(0,map {length ($_) > 100?1:-1} grep {/\S/} split /\n/,$body,20) > 0
+ ) {
+ $css_class .= " wrapping";
}
# Add links to URLs
# We don't html escape here because we escape above;
) {
# Add links to CVE vulnerabilities (closes #568464)
$body =~ s{(^|\s|[\(\[])(CVE-\d{4}-\d{4,})(\s|[,.-\[\]\)]|$)}
- {$1<a href="http://$config{cve_tracker}$2">$2</a>$3}gxm;
+ {$1<a href="$config{cve_tracker}$2">$2</a>$3}gxm;
}
if (not exists $param{att}) {
- print {$output} qq(<pre class="message">$body</pre>\n);
+ print {$output} qq(<pre class="$css_class">$body</pre>\n);
}
}
return 0;
my $entity;
my $tempdir;
if (not blessed $record) {
- my $parser = MIME::Parser->new();
- # this will be cleaned up once it goes out of scope
- $tempdir = File::Temp->newdir();
- $parser->output_under($tempdir->dirname());
- if ($record->{inner_file}) {
- $entity = $parser->parse($record->{fh}) or
- die "Unable to parse entity";
- } else {
- $entity = $parser->parse_data($record->{text}) or
- die "Unable to parse entity";
- }
+ $entity = parse_to_mime_entity($record);
} else {
$entity = $record;
}
# $record->{text} is not in perl's internal encoding; convert it
my $text = decode_rfc1522(decode_utf8(record_text($record)));
my ($time) = $text =~ /<!--\s+time:(\d+)\s+-->/;
- my $class = $text =~ /^<strong>(?:Acknowledgement|Reply|Information|Report|Notification)/m ? 'infmessage':'msgreceived';
+ my $class = $text =~ /^<strong>(?:Acknowledgement|Information|Report|Notification)/m ? 'infmessage':'msgreceived';
$output .= $text;
# Link to forwarded http:// urls in the midst of the report
# (even though these links already exist at the top)
# Add links to the cloned bugs
$output =~ s{(Bug )(\d+)( cloned as bugs? )(\d+)(?:\-(\d+)|)}{$1.bug_links(bug=>$2).$3.bug_links(bug=>(defined $5)?[$4..$5]:$4)}eo;
# Add links to merged bugs
- $output =~ s{(?<=Merged )([\d\s]+)(?=\.)}{join(' ',map {bug_links(bug=>$_)} (split /\s+/, $1))}eo;
+ $output =~ s{(?<=Merged )([\d\s]+)(?=[\.<])}{join(' ',map {bug_links(bug=>$_)} (split /\s+/, $1))}eo;
# Add links to blocked bugs
$output =~ s{(?<=Blocking bugs)(?:( of )(\d+))?( (?:added|set to|removed):\s+)([\d\s\,]+)}
{(defined $2?$1.bug_links(bug=>$2):'').$3.
(\d+(?:,\s+\d+)*(?:\,?\s+and\s+\d+)?)}
{$1.(defined $3?$2.bug_links(bug=>$3):'').$4.
english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}xeo;
- $output =~ s{([Aa]dded|[Rr]emoved)( indication that bug )(\d+)( blocks )([\d\s\,]+)}
+ $output =~ s{([Aa]dded|[Rr]emoved)( indication that bug )(\d+)( blocks ?)([\d\s\,]+)}
{$1.$2.(bug_links(bug=>$3)).$4.
english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}eo;
# Add links to reassigned packages
if (defined $time) {
$output .= ' ('.strftime('%a, %d %b %Y %T GMT',gmtime($time)).') ';
}
- $output .= '<a href="' .
+ $output .= qq{(<a href="} .
html_escape(bug_links(bug => $bug_number,
options => {msg => ($msg_number+1)},
links_only => 1,
)
- ) . '">
Full text</a> and <a href="' .
+ ) . '">
full text</a>, <a href="' .
html_escape(bug_links(bug => $bug_number,
options => {msg => ($msg_number+1),
mbox => 'yes'},
links_only => 1)
- ) . '">rfc822 format</a> available.';
+ ) . '">mbox</a>, '.
+ qq{<a href="#$msg_number">link</a>).</p>};
- $output = qq(<div class="$class"><hr>\n<a name="$msg_number"></a>\n) . $output . "</div>\n";
+ $output = qq(<div class="$class"><hr><p>\n<a name="$msg_number"></a>\n) . $output . "</p></div>\n";
}
elsif (/recips/) {
my ($msg_id) = record_regex($record,qr/^Message-Id:\s+<(.+)>/i);
elsif (defined $msg_id) {
$$seen_msg_ids{$msg_id} = 1;
}
- $output .= qq(<hr><p class="msgreceived"><a name="$msg_number"></a>\n);
+ return () if defined $param{spam} and $param{spam}->is_spam($msg_id);
+ $output .= qq(<hr><p class="msgreceived"><a name="$msg_number" href="#$msg_number">🔗</a>\n);
$output .= 'View this message in <a href="' . html_escape(bug_links(bug=>$bug_number, links_only => 1, options=>{msg=>$msg_number, mbox=>'yes'})) . '">rfc822 format</a></p>';
$output .= handle_email_message($record,
ref => $bug_number,
elsif (defined $msg_id) {
$$seen_msg_ids{$msg_id} = 1;
}
+ return () if defined $param{spam} and $param{spam}->is_spam($msg_id);
# Incomming Mail Message
my ($received,$hostname) = record_regex($record,qr/Received: \(at (\S+)\) by (\S+)\;/o);
$output .= qq|<hr><p class="msgreceived"><a name="$msg_number"></a><a name="msg$msg_number"></a><a href="#$msg_number">Message #$msg_number</a> received at |.
@EXPORT = ();
%EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
qw(appendfile overwritefile buglog getparsedaddrs getmaintainers),
+ qw(getsourcemaintainers getsourcemaintainers_reverse),
qw(bug_status),
qw(getmaintainers_reverse),
qw(getpseudodesc),
qw(package_maintainer),
qw(sort_versions),
+ qw(open_compressed_file),
],
misc => [qw(make_list globify_scalar english_join checkpid),
qw(cleanup_eval_fail),
die "Unable to rename ${file}.new to $file: $!";
}
+ =head2 open_compressed_file
+ my $fh = open_compressed_file('foo.gz') or
+ die "Unable to open compressed file: $!";
+
+
+ Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate
+ decompression program is forked and output from it is read.
+
+ This routine by default opens the file with UTF-8 encoding; if you want some
+ other encoding, specify it with the second option.
+
+ =cut
+ sub open_compressed_file {
+ my ($file,$encoding) = @_;
+ $encoding //= ':encoding(UTF-8)';
+ my $fh;
+ my $mode = "<$encoding";
+ my @opts;
+ if ($file =~ /\.gz$/) {
+ $mode = "-|$encoding";
+ push @opts,'gzip','-dc';
+ }
+ if ($file =~ /\.xz$/) {
+ $mode = "-|$encoding";
+ push @opts,'xz','-dc';
+ }
+ if ($file =~ /\.bz2$/) {
+ $mode = "-|$encoding";
+ push @opts,'bzip2','-dc';
+ }
+ open($fh,$mode,@opts,$file);
+ return $fh;
+ }
return $_maintainer_rev;
}
+=head2 getsourcemaintainers
+
+ my $maintainer = getsourcemaintainers()->{debbugs}
+
+Returns a hashref of src_package => maintainer pairs.
+
+=cut
+
+our $_source_maintainer = undef;
+our $_source_maintainer_rev = undef;
+sub getsourcemaintainers {
+ return $_source_maintainer if defined $_source_maintainer;
+ package_maintainer(rehash => 1);
+ return $_source_maintainer;
+}
+
+=head2 getsourcemaintainers_reverse
+
+ my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]};
+
+Returns a hashref of maintainer => [qw(list of source packages)] pairs.
+
+=cut
+
+sub getsourcemaintainers_reverse{
+ return $_source_maintainer_rev if defined $_source_maintainer_rev;
+ package_maintainer(rehash => 1);
+ return $_source_maintainer_rev;
+}
+
=head2 package_maintainer
my @s = package_maintainer(source => [qw(foo bar baz)],
=cut
-our $_source_maintainer = undef;
-our $_source_maintainer_rev = undef;
sub package_maintainer {
my %param = validate_with(params => \@_,
spec => {source => {type => SCALAR|ARRAYREF,
for my $fn (@config{('source_maintainer_file',
'source_maintainer_file_override',
'pseudo_maint_file')}) {
- next unless defined $fn;
+ next unless defined $fn and length $fn;
if (not -e $fn) {
warn "Missing source maintainer file '$fn'";
next;
for my $fn (@config{('maintainer_file',
'maintainer_file_override',
'pseudo_maint_file')}) {
- next unless defined $fn;
+ next unless defined $fn and length $fn;
if (not -e $fn) {
warn "Missing maintainer file '$fn'";
next;
}
$type //= 'address';
my $fh = IO::File->new($fn,'r') or
- die "Unable to open $fn for reading: $!";
+ croak "Unable to open $fn for reading: $!";
binmode($fh,':encoding(UTF-8)');
while (<$fh>) {
chomp;
return $_pseudodesc if defined $_pseudodesc;
$_pseudodesc = {};
__add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
- defined $config{pseudo_desc_file};
+ defined $config{pseudo_desc_file} and
+ length $config{pseudo_desc_file};
return $_pseudodesc;
}
qw($gWebDomain $gHTMLSuffix $gCGIDomain $gMirrors),
qw($gPackagePages $gSubscriptionDomain $gProject $gProjectTitle),
qw($gMaintainer $gMaintainerWebpage $gMaintainerEmail $gUnknownMaintainerEmail),
+ qw($gPackageTrackingDomain $gUsertagPackageDomain),
qw($gSubmitList $gMaintList $gQuietList $gForwardList),
qw($gDoneList $gRequestList $gSubmitterList $gControlList),
qw($gStrongList),
qw($gTemplateDir),
qw($gDefaultPackage),
qw($gSpamMaxThreads $gSpamSpamsPerThread $gSpamKeepRunning $gSpamScan $gSpamCrossassassinDb),
+ qw($gDebbugsDb),
],
text => [qw($gBadEmailPrefix $gHTMLTail $gHTMLExpireNote),
],
=item web_domain $gWebDomain
- Full path of the web domain where bugs are kept, defaults to the
- concatenation of L</web_host> and L</web_host_bug_dir>
+ Full path of the web domain where bugs are kept including the protocol (http://
+ or https://). Defaults to the concatenation of 'http://', L</web_host> and
+ L</web_host_bug_dir>
=cut
- set_default(\%config,'web_domain',$config{web_host}.($config{web_host}=~m{/$}?'':'/').$config{web_host_bug_dir});
+ set_default(\%config,'web_domain','http://'.$config{web_host}.($config{web_host}=~m{/$}?'':'/').$config{web_host_bug_dir});
=item html_suffix $gHTMLSuffix
=item cgi_domain $gCGIDomain
Full path of the web domain where cgi scripts are kept. Defaults to
- the concatentation of L</web_host> and cgi.
+ the concatentation of L</web_domain> and cgi.
=cut
=item package_pages $gPackagePages
Domain where the package pages are kept; links should work in a
- package_pages/foopackage manner. Defaults to undef, which means that
- package links will not be made.
+ package_pages/foopackage manner. Defaults to undef, which means that package
+ links will not be made. Should be prefixed with the appropriate protocol
+ (http/https).
=cut
set_default(\%config,'package_pages',undef);
+ =item package_tracking_domain $gPackageTrackingDomain
+
+ Domain where the package pages are kept; links should work in a
+ package_tracking_domain/foopackage manner. Defaults to undef, which means that
+ package links will not be made. Should be prefixed with the appropriate protocol
+ (http or https).
+
+ =cut
+
+ set_default(\%config,'package_tracking_domain',undef);
+
=item package_pages $gUsertagPackageDomain
Domain where where usertags of packages belong; defaults to $gPackagePages
=cut
- set_default(\%config,'usertag_package_domain',$config{package_pages});
+ set_default(\%config,'usertag_package_domain',map {my $a = $_; defined $a?$a =~ s{https?://}{}:(); $a} $config{package_pages});
=item subscription_domain $gSubscriptionDomain
set_default(\%config,'subscription_domain',undef);
+ =item cc_all_mails_to_addr $gCcAllMailsToAddr
+
+ Address to Cc (well, Bcc) all e-mails to
+
+ =cut
+
+ set_default(\%config,'cc_all_mails_to_addr',undef);
+
+
=item cve_tracker $gCVETracker
URI to CVE security tracker; in bugreport.cgi, CVE-2001-0002 becomes
- linked to http://$config{cve_tracker}CVE-2001-002
+ linked to $config{cve_tracker}CVE-2001-002
- Default: security-tracker.debian.org/tracker/
+ Default: https://security-tracker.debian.org/tracker/
=cut
- set_default(\%config,'cve_tracker','security-tracker.debian.org/tracker/');
+ set_default(\%config,'cve_tracker','https://security-tracker.debian.org/tracker/');
=back
For removal/archival purposes, all bugs are assumed to have these tags
set.
- Default: qw(unstable testing);
+ Default: qw(experimental unstable testing);
=cut
set_default(\%config,'removal_default_distribution_tags',
- [qw(unstable testing)]
+ [qw(experimental unstable testing)]
);
=item removal_strong_severity_default_distribution_tags
For removal/archival purposes, all bugs with strong severity are
assumed to have these tags set.
- Default: qw(unstable testing stable);
+ Default: qw(experimental unstable testing stable);
=cut
set_default(\%config,'removal_strong_severity_default_distribution_tags',
- [qw(unstable testing stable)]
+ [qw(experimental unstable testing stable)]
);
set_default(\%config,'sendmail_arguments',[qw(-oem -oi)]);
+ =item envelope_from
+
+ Envelope from to use for sent messages. If not set, whatever sendmail picks is
+ used.
+
+ =cut
+
+ set_default(\%config,'envelope_from',undef);
+
=item spam_scan
Whether or not spamscan is being used; defaults to 0 (not being used
=cut
- set_default(\%config,'libravatar_uri','http://'.$config{cgi_domain}.'/libravatar.cgi?email=');
+ set_default(\%config,'libravatar_uri',$config{cgi_domain}.'/libravatar.cgi?email=');
=item libravatar_uri_options $gLibravatarUriOptions
=back
+=head2 Database
+
+=over
+
+=item debbugs_db
+
+Name of debbugs PostgreSQL database service. If you wish to not use a service
+file, provide a full DBD::Pg compliant data-source, for example:
+C<"dbi:Pg:dbname=dbname">
+
+=back
+
+set_default(\%config,'debbugs_db',undef);
+
=head2 Text Fields
The following are the only text fields in general use in the scripts;
SUBSTITUTE_DTIME
<!--timestamp-->
<P>
- <A HREF=\"http://$config{web_domain}/\">Debian $config{bug} tracking system</A><BR>
+ <A HREF=\"$config{web_domain}/\">Debian $config{bug} tracking system</A><BR>
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.
+ </P>
</ADDRESS>
END
use Params::Validate qw(:types validate_with);
use Encode qw(encode encode_utf8 is_utf8);
use IO::InnerFile;
+ use feature 'state';
=head1 NAME
$param{inner_file} = 0;
}
else {
- %param = validate_with(params => \@_,
- spec => {bug_num => {type => SCALAR,
- optional => 1,
- },
- logfh => {type => HANDLE,
- optional => 1,
- },
- log_name => {type => SCALAR,
- optional => 1,
- },
- inner_file => {type => BOOLEAN,
- default => 0,
- },
- }
- );
+ state $spec =
+ {bug_num => {type => SCALAR,
+ optional => 1,
+ },
+ logfh => {type => HANDLE,
+ optional => 1,
+ },
+ log_name => {type => SCALAR,
+ optional => 1,
+ },
+ inner_file => {type => BOOLEAN,
+ default => 0,
+ },
+ };
+ %param = validate_with(params => \@_,
+ spec => $spec,
+ );
}
- if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) {
- croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined";
+ if (grep({exists $param{$_} and defined $param{$_}}
+ qw(bug_num logfh log_name)) ne 1) {
+ croak "Exactly one of bug_num, logfh, or log_name ".
+ "must be passed and must be defined";
}
my $class = ref($this) || $this;
bless $self, $class;
if (exists $param{logfh}) {
- $self->{logfh} = $param{logfh}
- }
- elsif (exists $param{log_name}) {
- $self->{logfh} = IO::File->new($param{log_name},'r') or
- die "Unable to open bug log $param{log_name} for reading: $!";
- }
- elsif (exists $param{bug_num}) {
- my $location = getbuglocation($param{bug_num},'log');
- my $bug_log = getbugcomponent($param{bug_num},'log',$location);
- $self->{logfh} = IO::File->new($bug_log, 'r') or
- die "Unable to open bug log $bug_log for reading: $!";
+ $self->{logfh} = $param{logfh}
+ } else {
+ my $bug_log;
+ if (exists $param{bug_num}) {
+ my $location = getbuglocation($param{bug_num},'log');
+ $bug_log = getbugcomponent($param{bug_num},'log',$location);
+ } else {
+ $bug_log = $param{log_name};
+ }
+ if ($bug_log =~ m/\.gz$/) {
+ my $oldpath = $ENV{'PATH'};
+ $ENV{'PATH'} = '/bin:/usr/bin';
+ open($self->{logfh},'-|','gzip','-dc',$bug_log) or
+ die "Unable to open $bug_log for reading: $!";
+ $ENV{'PATH'} = $oldpath;
+ } else {
+ open($self->{logfh},'<',$bug_log) or
+ die "Unable to open $bug_log for reading: $!";
+ }
}
$self->{state} = 'kill-init';
my $record = {};
while (defined (my $line = <$logfh>)) {
+ $record->{start} = $logfh->tell() if not defined $record->{start};
chomp $line;
++$this->{linenum};
if (length($line) == 1 and exists $states{ord($line)}) {
} else {
my @result = $record->{text} =~ m/$regex/;
return @result;
- return $record->{text};
}
}
=cut
1;
+
+ # Local Variables:
+ # indent-tabs-mode: nil
+ # cperl-indent-level: 4
+ # End:
@EXPORT = ();
- %EXPORT_TAGS = (mime => [qw(parse create_mime_message getmailbody)],
+ %EXPORT_TAGS = (mime => [qw(parse create_mime_message getmailbody),
+ qw(parse_to_mime_entity),
+ ],
rfc1522 => [qw(decode_rfc1522 encode_rfc1522)],
);
@EXPORT_OK=();
use MIME::Parser;
use POSIX qw(strftime);
- use List::MoreUtils qw(apply);
+ use List::AllUtils qw(apply);
# for convert_to_utf8
use Debbugs::UTF8 qw(convert_to_utf8);
return undef;
}
+=item parse_to_mime_entity
+
+ $entity = parse_to_mime_entity($record);
+
+Returns a MIME::Entity from a record (from Debbugs::Log), a filehandle, or a
+scalar mail message. Will die upon failure.
+
+Intermediate parsing results will be output under a temporary directory which
+should be cleaned up upon process exit.
+
+=cut
+
+sub parse_to_mime_entity {
+ my ($record) = @_;
+ my $parser = MIME::Parser->new();
+ my $entity;
+ # this will be cleaned up once we exit
+ my $tempdir = File::Temp->newdir();
+ $parser->output_dir($tempdir->dirname());
+ if (ref($record) eq 'HASH') {
+ if ($record->{inner_file}) {
+ $entity = $parser->parse($record->{fh}) or
+ die "Unable to parse entity";
+ } else {
+ $entity = $parser->parse_data($record->{text}) or
+ die "Unable to parse entity";
+ }
+ } elsif (ref($record)) {
+ $entity = $parser->parse($record) or
+ die "Unable to parse entity";
+ } else {
+ $entity = $parser->parse_data($record) or
+ die "Unable to parse entity";
+ }
+ return $entity;
+}
+
sub parse
{
# header and decoded body respectively
use Params::Validate qw(validate_with :types);
use Debbugs::Common qw(make_list globify_scalar sort_versions);
- use List::Util qw(min max);
+ use List::AllUtils qw(min max);
use IO::File;
our $_srcpkg;
sub getpkgsrc {
return $_pkgsrc if $_pkgsrc;
- return {} unless defined $Debbugs::Packages::gPackageSource;
+ return {} unless defined $config{package_source} and
+ length $config{package_source};
my %pkgsrc;
my %pkgcomponent;
my %srcpkg;
my $fh = IO::File->new($config{package_source},'r')
- or die("Unable to open $config{package_source} for reading: $!");
+ or croak("Unable to open $config{package_source} for reading: $!");
while(<$fh>) {
next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
my ($bin,$cmp,$src)=($1,$2,$3);
cache => {type => HASHREF,
default => {},
},
+ schema => {type => OBJECT,
+ optional => 1,
+ },
},
);
# TODO: This gets hit a lot, especially from buggyversion() - probably
# need an extra cache for speed here.
- return () unless defined $gBinarySourceMap;
+ return () unless defined $gBinarySourceMap or defined $param{schema};
if ($param{scalar_only} or not wantarray) {
$param{source_only} = 1;
my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]);
my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]);
return () unless @binaries;
+
+ # any src:foo is source package foo with unspecified version
+ @source = map {/^src:(.+)$/?
+ [$1,'']:()} @binaries;
+ @binaries = grep {$_ !~ /^src:/} @binaries;
+ if ($param{schema}) {
+ if ($param{source_only}) {
+ @source = map {$_->[0]} @source;
+ my $src_rs = $param{schema}->resultset('SrcPkg')->
+ search_rs({'binpkg.pkg' => [@binaries],
+ @versions?('bin_vers.ver' => [@versions]):(),
+ @archs?('arch.arch' => [@archs]):(),
+ },
+ {join => {'src_vers'=>
+ {'bin_vers'=> ['arch','bin_pkg']}
+ },
+ distinct => 1,
+ },
+ );
+ push @source,
+ map {$_->pkg} $src_rs->all;
+ if ($param{scalar_only}) {
+ return join(',',@source);
+ }
+ return @source;
+
+ }
+ my $src_rs = $param{schema}->resultset('SrcVer')->
+ search_rs({'bin_pkg.pkg' => [@binaries],
+ @versions?('bin_vers.ver' => [@versions]):(),
+ @archs?('arch.arch' => [@archs]):(),
+ },
+ {join => ['src_pkg',
+ {'bin_vers' => ['arch','binpkg']},
+ ],
+ distinct => 1,
+ },
+ );
+ push @source,
+ map {[$_->get_column('src_pkg.pkg'),
+ $_->get_column('src_ver.ver'),
+ ]} $src_rs->all;
+ if (not @source and not @versions and not @archs) {
+ $src_rs = $param{schema}->resultset('SrcPkg')->
+ search_rs({pkg => [@binaries]},
+ {distinct => 1},
+ );
+ push @source,
+ map {[$_->pkg,
+ ]} $src_rs->all;
+ }
+ return @source;
+ }
my $cache_key = join("\1",
join("\0",@binaries),
join("\0",@versions),
@{$param{cache}{$cache_key}};
}
for my $binary (@binaries) {
- if ($binary =~ m/^src:(.+)$/) {
- push @source,[$1,''];
- next;
- }
if (not tied %_binarytosource) {
tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or
die "Unable to open $config{binary_source_map} for reading";
}
}
else {
- my $found_one_version = 0;
for my $version (@versions) {
next unless exists $bin->{$version};
if (exists $bin->{$version}{all}) {
arch => 'source',
versions => '0.1.1',
guess_source => 1,
- debug => \$debug,
warnings => \$warnings,
);
},
);
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});
use Encode qw(decode encode is_utf8);
use Storable qw(dclone);
- use List::Util qw(min max);
+ use List::AllUtils qw(min max);
use Carp qw(croak);
my $status;
my $log;
my $location;
+ my $report;
if (not defined $param{summary}) {
my $lref;
($lref,$location) = @param{qw(bug location)};
}
$status = getbugcomponent($lref, 'summary', $location);
$log = getbugcomponent($lref, 'log' , $location);
+ $report = getbugcomponent($lref, 'report' , $location);
return undef unless defined $status;
return undef if not -e $status;
}
else {
$status = $param{summary};
$log = $status;
+ $report = $status;
$log =~ s/\.summary$/.log/;
+ $report =~ s/\.summary$/.report/;
($location) = $status =~ m/(db-h|db|archive)/;
($param{bug}) = $status =~ m/(\d+)\.summary$/;
}
my $status_modified = (stat($status))[9];
# Add log last modified time
$data{log_modified} = (stat($log))[9] // (stat("${log}.gz"))[9];
+ my $report_modified = (stat($report))[9] // $data{log_modified};
$data{last_modified} = max($status_modified,$data{log_modified});
+ # if the date isn't set (ancient bug), use the smallest of any of the modified
+ if (not defined $data{date} or not length($data{date})) {
+ $data{date} = min($report_modified,$status_modified,$data{log_modified});
+ }
$data{location} = $location;
$data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
$data{bug_num} = $param{bug};
+ # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=>
+ # and not include this bug
+ if (defined $data{mergedwith} and
+ $data{mergedwith}) {
+ $data{mergedwith} =
+ join(' ',
+ grep { $_ != $data{bug_num}}
+ sort { $a <=> $b }
+ split / /, $data{mergedwith}
+ );
+ }
return \%data;
}
return grep {length $_} map {split $splitter} @t;
};
-my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
+our $sort_and_unique = sub {
+ my @v;
+ my %u;
+ my $all_numeric = 1;
+ for my $v (@_) {
+ if ($all_numeric and $v =~ /\D/) {
+ $all_numeric = 0;
+ }
+ next if exists $u{$v};
+ $u{$v} = 1;
+ push @v, $v;
+ }
+ if ($all_numeric) {
+ return sort {$a <=> $b} @v;
+ } else {
+ return sort @v;
+ }
+};
+
+my $ditch_space_unique_and_sort = sub {return &{$sort_and_unique}(&{$ditch_empty}(' ',@_))};
my %split_fields =
(package => \&splitpackages,
affects => \&splitpackages,
- blocks => $ditch_empty_space,
- blockedby => $ditch_empty_space,
+ # Ideally we won't have to split source, but because some consumers of
+ # get_bug_status cannot handle arrayref, we will split it here.
+ source => \&splitpackages,
+ blocks => $ditch_space_unique_and_sort,
+ blockedby => $ditch_space_unique_and_sort,
# this isn't strictly correct, but we'll split both of them for
# the time being until we ditch all use of keywords everywhere
# from the code
- keywords => $ditch_empty_space,
- tags => $ditch_empty_space,
- found_versions => $ditch_empty_space,
- fixed_versions => $ditch_empty_space,
- mergedwith => $ditch_empty_space,
+ keywords => $ditch_space_unique_and_sort,
+ tags => $ditch_space_unique_and_sort,
+ found_versions => $ditch_space_unique_and_sort,
+ fixed_versions => $ditch_space_unique_and_sort,
+ mergedwith => $ditch_space_unique_and_sort,
);
sub split_status_fields {
=cut
sub lockreadbugmerge {
- my ($bug_num,$location) = @_;
my $data = lockreadbug(@_);
if (not defined $data) {
return (0,undef);
# are all merged with eachother
# We do a cmp sort instead of an <=> sort here, because that's
# what merge does
- my $expectmerge= join(' ',grep {$_ != $bug } sort @bugs);
+ my $expectmerge=
+ join(' ',grep {$_ != $bug }
+ sort { $a <=> $b }
+ @bugs);
if ($newdata->{mergedwith} ne $expectmerge) {
for (1..$locks) {
unfilelock(exists $param{locks}?$param{locks}:());
Standards-Version: 3.9.4
Vcs-Browser: http://bugs.debian.org/debbugs-source/mainline
Vcs-Git: http://bugs.debian.org/debbugs-source/debbugs.git
- Build-Depends: debhelper (>= 5)
+ Build-Depends: debhelper (>= 9)
Build-Depends-Indep: libparams-validate-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, libtest-pod-perl, liblist-moreutils-perl,
- libtext-template-perl, graphviz,
+ libconfig-simple-perl, libtest-pod-perl, liblist-allutils-perl,
+ # used by Debbugs::Libravatar and libravatar.cgi
+ libfile-libmagic-perl, libgravatar-url-perl, libwww-perl, imagemagick,
+ libdbix-class-perl, libdatetime-format-pg-perl,
- libdatetime-format-mail-perl
++ libdatetime-format-mail-perl,
+ libtext-template-perl, graphviz, libtext-iconv-perl
Homepage: http://wiki.debian.org/Teams/Debbugs
Package: debbugs
${perl:Depends},
${misc:Depends},
exim4 | mail-transport-agent,
- libdebbugs-perl,
- Recommends: debbugs-web
+ libdebbugs-perl
+ Recommends: debbugs-web (>= 2.6~)
Suggests: spamassassin (>= 3.0), libcgi-alert-perl
Description: bug tracking system based on the active Debian BTS
Debian has a bug tracking system which files details of bugs reported by
Package: libdebbugs-perl
Architecture: all
Depends:
- ${misc:Depends},
- ${perl:Depends}, libmailtools-perl, ed, libmime-tools-perl,
+ ${misc: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, liblist-moreutils-perl,
libtext-template-perl,
-# used by Debbugs::Libravatar and libravatar.cgi
- libfile-libmagic-perl, libgravatar-url-perl, libwww-perl, imagemagick
+ # used by Debbugs::Libravatar and libravatar.cgi
+ libfile-libmagic-perl,
+ libgravatar-url-perl, libwww-perl, imagemagick,
+ # used by the database
+ libdatetime-format-mail-perl, libdbix-class-perl, libdatetime-format-pg-perl
Section: perl
Description: modules used by the active Debian BTS
Debian has a bug tracking system which files details of bugs reported by
Package: debbugs-web
Architecture: all
Depends:
+ ${perl:Depends},
${misc:Depends},
libdebbugs-perl, apache2 | httpd
Suggests: libcgi-alert-perl, libapache2-mod-perl2
+ Replaces: debbugs (<< 2.4.2)
+ Breaks: debbugs (<< 2.4.2)
Description: web scripts for 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
Package: debbugs-local
Architecture: all
Depends:
+ ${perl:Depends},
${misc:Depends},
libdebbugs-perl, debbugs-web, libconfig-simple-perl,
libuser-perl, rsync, libhttp-server-simple-perl, libnet-server-perl
projects / debbugs.git / commitdiff