From: Don Armstrong Date: Sat, 5 Aug 2017 19:27:14 +0000 (-0700) Subject: Merge remote-tracking branch 'origin/master' into database X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=0c2305d4c89d165140bc955a50f3248c9c9ba7ad;hp=-c;p=debbugs.git Merge remote-tracking branch 'origin/master' into database --- 0c2305d4c89d165140bc955a50f3248c9c9ba7ad diff --combined Debbugs/Bugs.pm index 5ae0afa,f8e049d..095ed76 --- a/Debbugs/Bugs.pm +++ b/Debbugs/Bugs.pm @@@ -55,10 -55,10 +55,10 @@@ use Params::Validate qw(validate_with : 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 @@@ -152,65 -152,55 +152,65 @@@ bug should not =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; @@@ -223,7 -213,7 +223,7 @@@ 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 ($@) { @@@ -398,17 -388,45 +398,17 @@@ searches =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 = (); @@@ -432,11 -450,11 +432,11 @@@ 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"; @@@ -479,138 -497,6 +479,138 @@@ } +=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 @@@ -618,15 -504,55 +618,15 @@@ searches. [Or at least, that's the idea =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}) { diff --combined Debbugs/CGI/Bugreport.pm index fe037f0,7883cd5..dccae95 --- a/Debbugs/CGI/Bugreport.pm +++ b/Debbugs/CGI/Bugreport.pm @@@ -27,6 -27,7 +27,7 @@@ None known use warnings; use strict; + use utf8; use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); use Exporter qw(import); @@@ -34,7 -35,7 +35,7 @@@ use IO::Scalar 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; @@@ -44,6 -45,7 +45,7 @@@ use POSIX qw(strftime) 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{ @@@ -126,7 -128,6 +128,6 @@@ sub display_entity 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}; @@@ -263,11 -264,24 +264,24 @@@ 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; @@@ -290,10 -304,10 +304,10 @@@ ) { # Add links to CVE vulnerabilities (closes #568464) $body =~ s{(^|\s|[\(\[])(CVE-\d{4}-\d{4,})(\s|[,.-\[\]\)]|$)} - {$1$2$3}gxm; + {$1$2$3}gxm; } if (not exists $param{att}) { - print {$output} qq(
$body
\n); + print {$output} qq(
$body
\n); } } return 0; @@@ -321,7 -335,17 +335,7 @@@ sub handle_email_message 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; } @@@ -363,7 -387,7 +377,7 @@@ sub handle_record # $record->{text} is not in perl's internal encoding; convert it my $text = decode_rfc1522(decode_utf8(record_text($record))); my ($time) = $text =~ //; - my $class = $text =~ /^(?:Acknowledgement|Reply|Information|Report|Notification)/m ? 'infmessage':'msgreceived'; + my $class = $text =~ /^(?: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) @@@ -372,7 -396,7 +386,7 @@@ # 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. @@@ -381,7 -405,7 +395,7 @@@ (\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 @@@ -392,19 -416,20 +406,20 @@@ if (defined $time) { $output .= ' ('.strftime('%a, %d %b %Y %T GMT',gmtime($time)).') '; } - $output .= ' $bug_number, options => {msg => ($msg_number+1)}, links_only => 1, ) - ) . '">Full text and full text, rfc822 format available.'; + ) . '">mbox, '. + qq{link).

}; - $output = qq(
\n\n) . $output . "
\n"; + $output = qq(

\n\n) . $output . "

\n"; } elsif (/recips/) { my ($msg_id) = record_regex($record,qr/^Message-Id:\s+<(.+)>/i); @@@ -414,7 -439,8 +429,8 @@@ elsif (defined $msg_id) { $$seen_msg_ids{$msg_id} = 1; } - $output .= qq(

\n); + return () if defined $param{spam} and $param{spam}->is_spam($msg_id); + $output .= qq(

🔗\n); $output .= 'View this message in rfc822 format

'; $output .= handle_email_message($record, ref => $bug_number, @@@ -433,6 -459,7 +449,7 @@@ 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|

Message #$msg_number received at |. diff --combined Debbugs/Common.pm index aad3fe6,e892d70..ae7d8b4 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@@ -40,12 -40,12 +40,13 @@@ BEGIN @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), @@@ -240,7 -240,40 +241,40 @@@ sub overwritefile 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; + } @@@ -300,36 -333,6 +334,36 @@@ sub getmaintainers_reverse 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)], @@@ -355,6 -358,8 +389,6 @@@ files; defaults to =cut -our $_source_maintainer = undef; -our $_source_maintainer_rev = undef; sub package_maintainer { my %param = validate_with(params => \@_, spec => {source => {type => SCALAR|ARRAYREF, @@@ -393,7 -398,7 +427,7 @@@ 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; @@@ -409,7 -414,7 +443,7 @@@ 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; @@@ -460,7 -465,7 +494,7 @@@ sub __add_to_hash } $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; @@@ -500,7 -505,8 +534,8 @@@ sub getpseudodesc 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; } diff --combined Debbugs/Config.pm index 1811631,a02072c..596d053 --- a/Debbugs/Config.pm +++ b/Debbugs/Config.pm @@@ -47,6 -47,7 +47,7 @@@ BEGIN 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), @@@ -75,7 -76,6 +76,7 @@@ qw($gTemplateDir), qw($gDefaultPackage), qw($gSpamMaxThreads $gSpamSpamsPerThread $gSpamKeepRunning $gSpamScan $gSpamCrossassassinDb), + qw($gDebbugsDb), ], text => [qw($gBadEmailPrefix $gHTMLTail $gHTMLExpireNote), ], @@@ -152,12 -152,13 +153,13 @@@ set_default(\%config,'web_host_bug_dir' =item web_domain $gWebDomain - Full path of the web domain where bugs are kept, defaults to the - concatenation of L and L + Full path of the web domain where bugs are kept including the protocol (http:// + or https://). Defaults to the concatenation of 'http://', L and + L =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 @@@ -170,7 -171,7 +172,7 @@@ set_default(\%config,'html_suffix','.ht =item cgi_domain $gCGIDomain Full path of the web domain where cgi scripts are kept. Defaults to - the concatentation of L and cgi. + the concatentation of L and cgi. =cut @@@ -188,21 -189,33 +190,33 @@@ set_default(\%config,'mirrors',[]) =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 @@@ -214,16 -227,25 +228,25 @@@ Domain where subscriptions to package l 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 @@@ -527,12 -549,12 +550,12 @@@ set_default(\%config,'removal_distribut 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 @@@ -540,12 -562,12 +563,12 @@@ 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)] ); @@@ -868,6 -890,15 +891,15 @@@ Default arguments to pass to sendmail. 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 @@@ -976,7 -1007,7 +1008,7 @@@ libravatar.cgi, our internal federated =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 @@@ -1027,20 -1058,6 +1059,20 @@@ set_default(\%config,'libravatar_blackl =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; @@@ -1087,10 -1104,11 +1119,11 @@@ set_default(\%config,'html_tail',<

- Debian $config{bug} tracking system
+ Debian $config{bug} tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson. +

END diff --combined Debbugs/Log.pm index e97bfac,2531a6d..d824d9a --- a/Debbugs/Log.pm +++ b/Debbugs/Log.pm @@@ -41,6 -41,7 +41,7 @@@ use Debbugs::Common qw(getbuglocation g use Params::Validate qw(:types validate_with); use Encode qw(encode encode_utf8 is_utf8); use IO::InnerFile; + use feature 'state'; =head1 NAME @@@ -173,24 -174,28 +174,28 @@@ sub ne $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; @@@ -198,17 -203,25 +203,25 @@@ 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'; @@@ -236,7 -249,6 +249,7 @@@ sub read_recor 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)}) { @@@ -500,7 -512,6 +513,6 @@@ sub record_regex } else { my @result = $record->{text} =~ m/$regex/; return @result; - return $record->{text}; } } @@@ -513,3 -524,8 +525,8 @@@ simply a means for extracting and rewri =cut 1; + + # Local Variables: + # indent-tabs-mode: nil + # cperl-indent-level: 4 + # End: diff --combined Debbugs/MIME.pm index adc4566,1d8fcb5..8644c35 --- a/Debbugs/MIME.pm +++ b/Debbugs/MIME.pm @@@ -41,9 -41,7 +41,9 @@@ BEGIN @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=(); @@@ -56,7 -54,7 +56,7 @@@ use File::Temp qw(tempdir) 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); @@@ -90,43 -88,6 +90,43 @@@ sub getmailbod 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 diff --combined Debbugs/Packages.pm index d35f269,6980315..877466f --- a/Debbugs/Packages.pm +++ b/Debbugs/Packages.pm @@@ -39,7 -39,7 +39,7 @@@ use Storable qw(dclone) 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; @@@ -72,13 -72,14 +72,14 @@@ our $_pkgcomponent 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); @@@ -186,15 -187,12 +187,15 @@@ sub binary_to_source 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; @@@ -206,59 -204,6 +207,59 @@@ 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), @@@ -269,6 -214,10 +270,6 @@@ @{$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"; @@@ -286,7 -235,6 +287,6 @@@ } } else { - my $found_one_version = 0; for my $version (@versions) { next unless exists $bin->{$version}; if (exists $bin->{$version}{all}) { @@@ -582,7 -530,6 +582,6 @@@ sub makesourceversions arch => 'source', versions => '0.1.1', guess_source => 1, - debug => \$debug, warnings => \$warnings, ); @@@ -625,7 -572,6 +624,6 @@@ sub make_source_versions }, ); 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}); diff --combined Debbugs/Status.pm index 42dc850,4b8d82e..62cba34 --- a/Debbugs/Status.pm +++ b/Debbugs/Status.pm @@@ -49,7 -49,7 +49,7 @@@ use File::Copy qw(copy) 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); @@@ -191,7 -191,6 +191,7 @@@ sub read_bug my $status; my $log; my $location; + my $report; if (not defined $param{summary}) { my $lref; ($lref,$location) = @param{qw(bug location)}; @@@ -201,16 -200,13 +201,16 @@@ } $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$/; } @@@ -281,16 -277,22 +281,27 @@@ 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; } @@@ -312,39 -314,23 +323,42 @@@ our $ditch_empty = sub 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, + # 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_empty_space, - blockedby => $ditch_empty_space, + 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 { @@@ -444,7 -430,6 +458,6 @@@ data =cut sub lockreadbugmerge { - my ($bug_num,$location) = @_; my $data = lockreadbug(@_); if (not defined $data) { return (0,undef); @@@ -542,7 -527,10 +555,10 @@@ sub lock_read_all_merged_bugs # 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}:()); diff --combined debian/control index 19d9da1,7bd5999..6fadd40 --- a/debian/control +++ b/debian/control @@@ -6,16 -6,16 +6,18 @@@ Uploaders: Colin Watson = 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 @@@ -24,8 -24,8 +26,8 @@@ Depends ${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 @@@ -41,16 -41,14 +43,16 @@@ 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 @@@ -65,9 -63,12 +67,12 @@@ 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 @@@ -80,6 -81,7 +85,7 @@@ 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