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=356bc18cec24cb1d87ea62f222a0b30ff817855d;p=debbugs.git Merge remote-tracking branch 'origin/master' into database --- diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..0fd2461 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,20 @@ +dist: trusty +sudo: required +before_install: + - sudo apt-get -qq update + - > + sudo apt-get install -y 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-allutils-perl libtext-template-perl graphviz + libfile-libmagic-perl libgravatar-url-perl libwww-perl imagemagick +script: + - make; make test +notifications: + irc: + channels: + - "irc.oftc.net#debbugs" + email: false diff --git a/Debbugs/Bugs.pm b/Debbugs/Bugs.pm index 5ae0afa..095ed76 100644 --- a/Debbugs/Bugs.pm +++ b/Debbugs/Bugs.pm @@ -58,7 +58,7 @@ use Debbugs::Packages qw(getsrcpkgs getpkgsrc); 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 diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm index cd5f6e3..c70f682 100644 --- a/Debbugs/CGI.pm +++ b/Debbugs/CGI.pm @@ -49,7 +49,7 @@ use Mail::Address; use POSIX qw(ceil); use Storable qw(dclone); -use List::Util qw(max); +use List::AllUtils qw(max); use File::stat; use Digest::MD5 qw(md5_hex); use Carp; @@ -292,7 +292,9 @@ sub cgi_parameters { sub quitcgi { - my $msg = shift; + my ($msg, $status) = @_; + $status //= '500 Internal Server Error'; + print "Status: $status\n"; print "Content-Type: text/html\n\n"; print fill_in_template(template=>'cgi/quit', variables => {msg => $msg} @@ -622,10 +624,6 @@ sub htmlize_maintlinks { return htmlize_addresslinks($prefixfunc, \&mainturl, $maints); } - -our $_maintainer; -our $_maintainer_rev; - =head2 bug_linklist bug_linklist($separator,$class,@bugs) @@ -841,7 +839,6 @@ sub option_form{ for my $key (keys %{$param{form_option}}) { # strip out leader; shouldn't be anything here without one, # but skip stupid things anyway - my $o_key = $key; next unless $key =~ s/^\Q$form_option_leader\E//; if ($key =~ /^add_(.+)$/) { # this causes a specific parameter to be added diff --git a/Debbugs/CGI/Bugreport.pm b/Debbugs/CGI/Bugreport.pm index fe037f0..dccae95 100644 --- a/Debbugs/CGI/Bugreport.pm +++ b/Debbugs/CGI/Bugreport.pm @@ -27,6 +27,7 @@ None known. use warnings; use strict; +use utf8; use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); use Exporter qw(import); @@ -44,6 +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 @@ 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 @@ sub display_entity { 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 @@ sub display_entity { ) { # 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; @@ -363,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 +386,7 @@ sub handle_record{ # 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 +395,7 @@ sub handle_record{ (\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 +406,20 @@ sub handle_record{ 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 +429,8 @@ sub handle_record{ 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 +449,7 @@ sub handle_record{ 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 --git a/Debbugs/CGI/Pkgreport.pm b/Debbugs/CGI/Pkgreport.pm index 3e9cb3f..4391197 100644 --- a/Debbugs/CGI/Pkgreport.pm +++ b/Debbugs/CGI/Pkgreport.pm @@ -128,7 +128,7 @@ sub generate_package_info{ my @references; my $pseudodesc = getpseudodesc(); if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) { - push @references, "to the ". + push @references, "to the ". "list of other pseudo-packages"; } elsif (not defined $maint and not @{$param{bugs}}) { @@ -141,14 +141,14 @@ sub generate_package_info{ else { if ($package and defined $config{package_pages} and length $config{package_pages}) { push @references, sprintf "to the %s package page", - html_escape("http://$config{package_pages}/$package"), html_escape("$package"); + html_escape("$config{package_pages}/$package"), html_escape("$package"); } if (defined $config{subscription_domain} and length $config{subscription_domain}) { my $ptslink = $param{binary} ? $srcforpkg : $package; # the pts only wants the source, and doesn't care about src: (#566089) $ptslink =~ s/^src://; - push @references, q(to the Package Tracking System); + push @references, q(to the Package Tracking System); } # Only output this if the source listing is non-trivial. if ($param{binary} and $srcforpkg) { @@ -166,7 +166,7 @@ sub generate_package_info{ if (defined $maint) { print {$output} "

If you find a bug not listed here, please\n"; printf {$output} "report it.

\n", - html_escape("http://$config{web_domain}/Reporting$config{html_suffix}"); + html_escape("$config{web_domain}/Reporting$config{html_suffix}"); } return decode_utf8($output_scalar); } diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm index aad3fe6..ae7d8b4 100644 --- a/Debbugs/Common.pm +++ b/Debbugs/Common.pm @@ -46,6 +46,7 @@ BEGIN{ 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 +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; +} @@ -393,7 +427,7 @@ sub package_maintainer { 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 +443,7 @@ sub package_maintainer { 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 +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 +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 --git a/Debbugs/Config.pm b/Debbugs/Config.pm index 1811631..596d053 100644 --- a/Debbugs/Config.pm +++ b/Debbugs/Config.pm @@ -47,6 +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), @@ -152,12 +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 +172,7 @@ set_default(\%config,'html_suffix','.html'); =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 +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 +228,25 @@ Domain where subscriptions to package lists happen 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 +550,12 @@ set_default(\%config,'removal_distribution_tags', 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 +563,12 @@ set_default(\%config,'removal_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)] ); @@ -868,6 +891,15 @@ Default arguments to pass to sendmail. Defaults to C. 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 +1008,7 @@ libravatar.cgi, our internal federated libravatar system. =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 @@ -1087,10 +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 --git a/Debbugs/Control.pm b/Debbugs/Control.pm index 226cd1f..ab60384 100644 --- a/Debbugs/Control.pm +++ b/Debbugs/Control.pm @@ -134,7 +134,7 @@ use Mail::RFC822::Address qw(); use POSIX qw(strftime); use Storable qw(dclone nfreeze); -use List::Util qw(first max); +use List::AllUtils qw(first max); use Encode qw(encode_utf8); use Carp; @@ -444,7 +444,6 @@ sub set_blocks { } } } - my @new_blockers = keys %blockers; for my $data (@data) { my $old_data = dclone($data); # remove blockers and/or add new ones as appropriate @@ -487,9 +486,7 @@ sub set_blocks { $mungable_blocks{add} = \%added_blockers if keys %added_blockers; my $new_locks = 0; 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 ($temp_locks, @blocking_data) = @@ -628,10 +625,8 @@ sub set_tag { __begin_control(%param, command => 'tag' ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; + my $transcript = $info{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}) { @@ -649,11 +644,9 @@ sub set_tag { my $action = 'Did not alter tags'; my %tag_added = (); my %tag_removed = (); - my %fixed_removed = (); my @old_tags = split /\,?\s+/, $data->{keywords}; 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; @@ -773,10 +766,8 @@ sub set_severity { __begin_control(%param, command => 'severity' ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; + my $transcript = $info{transcript}; my @data = @{$info{data}}; - my @bugs = @{$info{bugs}}; my $action = ''; for my $data (@data) { @@ -878,10 +869,8 @@ sub set_done { __begin_control(%param, command => $param{reopen}?'reopen':'done', ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; + my $transcript = $info{transcript}; my @data = @{$info{data}}; - my @bugs = @{$info{bugs}}; my $action =''; if ($param{reopen}) { @@ -941,7 +930,6 @@ sub set_done { } else { my %submitter_notified; - my $requester_notified = 0; my $orig_report_set = 0; for my $data (@data) { if (exists $data->{done} and @@ -1100,7 +1088,6 @@ sub set_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]) { @@ -1215,7 +1202,6 @@ sub set_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); @@ -1304,7 +1290,6 @@ sub set_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); @@ -1399,7 +1384,6 @@ sub set_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(',', @@ -1523,7 +1507,6 @@ sub set_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; @@ -1743,7 +1726,6 @@ sub set_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; @@ -1970,7 +1952,6 @@ sub set_merged { return; } my @data = @{$info{data}}; - my @bugs = @{$info{bugs}}; my %data; my %merged_bugs; for my $data (@data) { @@ -1981,7 +1962,6 @@ sub set_merged { # handle unmerging my $new_locks = 0; if (not exists $param{merge_with}) { - my $ok_to_unmerge = 1; delete $merged_bugs{$param{bug}}; if (not keys %merged_bugs) { print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n"; @@ -1995,8 +1975,11 @@ sub set_merged { $data->{mergedwith} = ''; } else { - $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}} - keys %merged_bugs); + $data->{mergedwith} = + join(' ', + sort {$a <=> $b} + grep {$_ != $data->{bug_num}} + keys %merged_bugs); } append_action_to_log(bug => $data->{bug_num}, command => 'merge', @@ -2015,9 +1998,6 @@ sub set_merged { return; } # lock and load all of the bugs we need - my @bugs_to_load = keys %merging; - my $bug_to_load; - my %merge_added; my ($data,$n_locks) = __lock_and_load_merged_bugs(bugs_to_load => [keys %merging], data => \@data, @@ -2109,7 +2089,6 @@ sub set_merged { my %target_blockedby; @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}}; my %unhandled_targets = %target_blockedby; - my @blocks_to_remove; for my $key (split / /,$change->{orig_value}) { delete $unhandled_targets{$key}; next if exists $target_blockedby{$key}; @@ -2181,11 +2160,14 @@ sub set_merged { } # finally, we can merge the bugs - my $action = "Merged ".join(' ',sort keys %merged_bugs); + my $action = "Merged ".join(' ',sort { $a <=> $b } keys %merged_bugs); for my $data (@data) { my $old_data = dclone($data); - $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}} - keys %merged_bugs); + $data->{mergedwith} = + join(' ', + sort { $a <=> $b } + grep {$_ != $data->{bug_num}} + keys %merged_bugs); append_action_to_log(bug => $data->{bug_num}, command => 'merge', new_data => $data, @@ -2560,7 +2542,6 @@ sub affects { my ($debug,$transcript) = @info{qw(debug transcript)}; my @data = @{$info{data}}; - my @bugs = @{$info{bugs}}; my $action = ''; for my $data (@data) { $action = ''; @@ -2738,7 +2719,6 @@ sub _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 = ''; @@ -2748,7 +2728,7 @@ sub _summary { print {$debug} "Removing $cmd fields\n"; $action = "Removed $cmd"; } - elsif ($param{$cmd} =~ /^\d+$/) { + elsif ($param{$cmd} =~ /^-?\d+$/) { my $log = []; my @records = Debbugs::Log::read_log_records(bug_num => $param{bug}); if ($param{$cmd} == 0 or $param{$cmd} == -1) { @@ -2894,10 +2874,8 @@ sub clone_bug { __begin_control(%param, command => 'clone' ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; + my $transcript = $info{transcript}; my @data = @{$info{data}}; - my @bugs = @{$info{bugs}}; my $action = ''; for my $data (@data) { @@ -2964,7 +2942,8 @@ sub clone_bug { for my $bug (split ' ', $data->{blocks}) { for my $new_bug (@new_bugs) { set_blocks(bug => $bug, - block => $new_bug, + block => $new_bug, + add => 1, hash_slice(%param, keys %common_options, keys %append_action_options), @@ -2975,7 +2954,8 @@ sub clone_bug { for my $bug (split ' ', $data->{blockedby}) { for my $new_bug (@new_bugs) { set_blocks(bug => $new_bug, - block => $bug, + block => $bug, + add => 1, hash_slice(%param, keys %common_options, keys %append_action_options), @@ -3029,7 +3009,6 @@ sub 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"; @@ -3242,7 +3221,6 @@ sub bug_unarchive { command=>'unarchive'); my ($debug,$transcript) = @info{qw(debug transcript)}; - my @data = @{$info{data}}; my @bugs = @{$info{bugs}}; my $action = "$config{bug} unarchived."; my @files_to_remove; @@ -3820,7 +3798,7 @@ LIMIT: for my $limit (make_list($param{limit}{$field})) { } if (not $match) { $going_to_fail = 1; - print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})). + print {$transcript} qq($field: ').join(', ',map{qq("$_")} make_list($data->{$field})). "' does not match at least one of ". join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n"; } @@ -3863,7 +3841,7 @@ sub __message_body_template{ $extra_var ||={}; my $hole_var = {'&bugurl' => sub{"$_[0]: ". - 'http://'.$config{cgi_domain}.'/'. + $config{cgi_domain}.'/'. Debbugs::CGI::bug_links(bug => $_[0], links_only => 1, ); diff --git a/Debbugs/Control/Service.pm b/Debbugs/Control/Service.pm index 42f3801..52d7d10 100644 --- a/Debbugs/Control/Service.pm +++ b/Debbugs/Control/Service.pm @@ -94,7 +94,7 @@ use Debbugs::Common qw(cleanup_eval_fail); use Debbugs::Control qw(:all); use Debbugs::Status qw(splitpackages); use Params::Validate qw(:types validate_with); -use List::Util qw(first); +use List::AllUtils qw(first); my $bug_num_re = '-?\d+'; my %control_grammar = @@ -561,9 +561,7 @@ sub control_line { print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n"; } } elsif ($ctl eq 'clone') { - my $origref = $matches[0]; my @newclonedids = split /\s+/, $matches[1]; - my $newbugsneeded = scalar(@newclonedids); eval { my %new_clones; diff --git a/Debbugs/DebArchive.pm b/Debbugs/DebArchive.pm new file mode 100644 index 0000000..ccb321a --- /dev/null +++ b/Debbugs/DebArchive.pm @@ -0,0 +1,204 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later +# version at your option. +# See the file README and COPYING for more information. +# +# Copyright 2017 by Don Armstrong . + +package Debbugs::DebArchive; + +use warnings; +use strict; + +=head1 NAME + +Debbugs::DebArchive -- Routines for reading files from Debian archives + +=head1 SYNOPSIS + +use Debbugs::DebArchive; + + read_packages('/srv/mirrors/ftp.debian.org/ftp/dist', + sub { print map {qq($_\n)} @_ }, + Term::ProgressBar->new(), + ); + + +=head1 DESCRIPTION + +This module implements a set of routines for reading Packages.gz, Sources.gz and +Release files from the dists directory of a Debian archive. + +=head1 BUGS + +None known. + +=cut + + +use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT); +use base qw(Exporter); + +BEGIN { + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (read => [qw(read_release_file read_packages), + ], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use File::Spec qw(); +use File::Basename; +use Debbugs::Config qw(:config); +use Debbugs::Common qw(open_compressed_file make_list); +use IO::Dir; + +use Carp; + +=over + +=item read_release_file + + read_release_file('stable/Release') + +Reads a Debian release file and returns a hashref of information about the +release file, including the Packages and Sources files for that distribution + +=cut + +sub read_release_file { + my ($file) = @_; + # parse release + my $rfh = open_compressed_file($file) or + die "Unable to open $file for reading: $!"; + my %dist_info; + my $in_sha1; + my %p_f; + while (<$rfh>) { + chomp; + if (s/^(\S+):\s*//) { + if ($1 eq 'SHA1'or $1 eq 'SHA256') { + $in_sha1 = 1; + next; + } + $dist_info{$1} = $_; + } elsif ($in_sha1) { + s/^\s//; + my ($sha,$size,$f) = split /\s+/,$_; + next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/; + next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$}; + my ($component,$arch,$package_source) = ($1,$2,$3); + $arch =~ s/binary-//; + next if exists $p_f{$component}{$arch} and + $p_f{$component}{$arch} =~ /\.xz$/; + $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f); + } + } + return (\%dist_info,\%p_f); +} + +=item read_packages + + read_packages($dist_dir,$callback,$progress) + +=over + +=item dist_dir + +Path to dists directory + +=item callback + +Function which is called with key, value pairs of suite, arch, component, +Package, Source, Version, and Maintainer information for each package in the +Packages file. + +=item progress + +Optional Term::ProgressBar object to output progress while reading packages. + +=back + + +=cut + +sub read_packages { + my ($dist_dir,$callback,$p) = @_; + + my %s_p; + my $tot = 0; + for my $dist (make_list($dist_dir)) { + my $dist_dir_h = IO::Dir->new($dist); + my @dist_names = + grep { $_ !~ /^\./ and + -d $dist.'/'.$_ and + not -l $dist.'/'.$_ + } $dist_dir_h->read or + die "Unable to read from dir: $!"; + $dist_dir_h->close or + die "Unable to close dir: $!"; + while (my $dist = shift @dist_names) { + my $dir = $dist_dir.'/'.$dist; + my ($dist_info,$package_files) = + read_release_file(File::Spec->catfile($dist_dir, + $dist, + 'Release')); + $s_p{$dist_info->{Codename}} = $package_files; + } + for my $suite (keys %s_p) { + for my $component (keys %{$s_p{$suite}}) { + $tot += scalar keys %{$s_p{$suite}{$component}}; + } + } + } + $p->target($tot) if $p; + my $done_archs = 0; + # parse packages files + for my $suite (keys %s_p) { + my $pkgs = 0; + for my $component (keys %{$s_p{$suite}}) { + my @archs = keys %{$s_p{$suite}{$component}}; + if (grep {$_ eq 'source'} @archs) { + @archs = ('source',grep {$_ ne 'source'} @archs); + } + for my $arch (@archs) { + my $pfh = open_compressed_file($s_p{$suite}{$component}{$arch}) or + die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!"; + local $_; + local $/ = ''; # paragraph mode + while (<$pfh>) { + my %pkg; + for my $field (qw(Package Maintainer Version Source)) { + /^\Q$field\E: (.*)/m; + $pkg{$field} = $1; + } + next unless defined $pkg{Package} and + defined $pkg{Version}; + $pkg{suite} = $suite; + $pkg{arch} = $arch; + $pkg{component} = $component; + $callback->(%pkg); + } + $p->update(++$done_archs) if $p; + } + } + } + $p->remove() if $p; +} + +=back + +=cut + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/Estraier.pm b/Debbugs/Estraier.pm index 7ada02d..174ad4c 100644 --- a/Debbugs/Estraier.pm +++ b/Debbugs/Estraier.pm @@ -95,7 +95,6 @@ sub remove_old_messages{ my $cond = new Search::Estraier::Condition; $cond->add_attr('@uri STRBW '.$bug_num.'/'); $cond->set_max(50); - my $skip; my $nres; while ($nres = $est->search($cond,0) and $nres->doc_num > 0){ for my $rdoc (map {$nres->get_doc($_)} 0..($nres->doc_num-1)) { diff --git a/Debbugs/Libravatar.pm b/Debbugs/Libravatar.pm index 0c84943..373a9f5 100644 --- a/Debbugs/Libravatar.pm +++ b/Debbugs/Libravatar.pm @@ -58,6 +58,8 @@ BEGIN{ } +our $magic; + =over =item retrieve_libravatar @@ -103,7 +105,7 @@ sub retrieve_libravatar{ } require LWP::UserAgent; - my $dest_type; + my $dest_type = 'png'; eval { my $uri = libravatar_url(email => $param{email}, default => 404, @@ -116,9 +118,21 @@ sub retrieve_libravatar{ $ua->timeout(10); # if the avatar is bigger than 30K, we don't want it either $ua->max_size(30*1024); + $ua->default_header('Accept' => 'image/*'); my $r = $ua->get($uri); if (not $r->is_success()) { - die "Not successful in request"; + if ($r->code != 404) { + die "Not successful in request"; + } + # No avatar - cache a negative result + if ($config{libravatar_default_image} =~ m/\.(png|jpg)$/) { + $dest_type = $1; + + system('cp', '-laf', $config{libravatar_default_image}, $cache_location.'.'.$dest_type) == 0 + or die("Cannot copy $config{libravatar_default_image}"); + # Returns from eval {} + return; + } } my $aborted = $r->header('Client-Aborted'); # if we exceeded max size, I'm not sure if we'll be @@ -128,10 +142,11 @@ sub retrieve_libravatar{ my $type = $r->header('Content-Type'); # if there's no content type, or it's not one we like, we won't # bother going further - die "No content type" if not defined $type; - die "Wrong content type" if not $type =~ m{^image/([^/]+)$}; - $dest_type = $type_mapping{$1}; - die "No dest type" if not defined $dest_type; + if (defined $type) { + die "Wrong content type" if not $type =~ m{^image/([^/]+)$}; + $dest_type = $type_mapping{$1}; + die "No dest type" if not defined $dest_type; + } # undo any content encoding $r->decode() or die "Unable to decode content encoding"; # ok, now we need to convert it from whatever it is into a @@ -141,7 +156,14 @@ sub retrieve_libravatar{ eval { print {$temp_fh} $r->content() or die "Unable to print to temp file"; - close ($temp_fh); + close ($temp_fh) or + die "Unable to close temp file"; + ### Figure out the actual type from the file + $magic = File::LibMagic->new() if not defined $magic; + $type = $magic->checktype_filename(abs_path($temp_fn)); + die "Wrong content type ($type)" if not $type =~ m{^image/([^/;]+)(?:;|$)}; + $dest_type = $type_mapping{$1}; + die "No dest type for ($1)" if not defined $dest_type; ### resize all images to 80x80 and strip comments out of ### them. If convert has a bug, it would be possible for ### this to be an attack vector, but hopefully minimizing @@ -203,7 +225,8 @@ sub cache_location { croak("cache_location must be called with one of md5sum or email"); } return (undef, 0) if blocked_libravatar($param{email},$md5sum); - $stem = $config{libravatar_cache_dir}.'/'.$md5sum; + my $cache_dir = $param{cache_dir} // $config{libravatar_cache_dir}; + $stem = $cache_dir.'/'.$md5sum; for my $ext ('.png', '.jpg', '') { my $path = $stem.$ext; if (-e $path) { @@ -283,8 +306,6 @@ sub handler { -our $magic; - sub serve_cache_mod_perl { my ($cache_location,$r,$timestamp) = @_; if (not defined $cache_location or not length $cache_location) { diff --git a/Debbugs/Log.pm b/Debbugs/Log.pm index e97bfac..d824d9a 100644 --- a/Debbugs/Log.pm +++ b/Debbugs/Log.pm @@ -41,6 +41,7 @@ use Debbugs::Common qw(getbuglocation getbugcomponent make_list); 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 @@ sub new $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 @@ sub new 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'; @@ -500,7 +513,6 @@ sub record_regex { } else { my @result = $record->{text} =~ m/$regex/; return @result; - return $record->{text}; } } @@ -513,3 +525,8 @@ simply a means for extracting and rewriting raw records. =cut 1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/Log/Spam.pm b/Debbugs/Log/Spam.pm new file mode 100644 index 0000000..ab0bc7c --- /dev/null +++ b/Debbugs/Log/Spam.pm @@ -0,0 +1,199 @@ +# This module is part of debbugs, and is released under the terms of the GPL +# version 2, or any later version (at your option). See the file README and +# COPYING for more information. +# +# Copyright 2017 by Don Armstrong . + +package Debbugs::Log::Spam; + +=head1 NAME + +Debbugs::Log::Spam -- an interface to debbugs .log.spam files + +=head1 SYNOPSIS + +use Debbugs::Log::Spam; + +my $spam = Debbugs::Log::Spam->new(bug_num => '12345'); + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use base qw(Exporter); + +BEGIN{ + $VERSION = 1; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; + +} + +use Carp; +use feature 'state'; +use Params::Validate qw(:types validate_with); +use Debbugs::Common qw(getbuglocation getbugcomponent filelock unfilelock); + +=head1 FUNCTIONS + +=over 4 + +=item new + +Creates a new log spam reader. + + my $spam_log = Debbugs::Log::Spam->new(log_spam_name => "56/123456.log.spam"); + my $spam_log = Debbugs::Log::Spam->new(bug_num => $nnn); + +Parameters + +=over + +=item bug_num -- bug number + +=item log_spam_name -- name of log + +=back + +One of the above options must be passed. + +=cut + +sub new { + my $this = shift; + state $spec = + {bug_num => {type => SCALAR, + optional => 1, + }, + log_spam_name => {type => SCALAR, + optional => 1, + }, + }; + my %param = + validate_with(params => \@_, + spec => $spec + ); + if (grep({exists $param{$_} and + defined $param{$_}} qw(bug_num log_spam_name)) ne 1) { + croak "Exactly one of bug_num or log_spam_name". + "must be passed and must be defined"; + } + + my $class = ref($this) || $this; + my $self = {}; + bless $self, $class; + + if (exists $param{log_spam_name}) { + $self->{name} = $param{log_spam_name}; + } elsif (exists $param{bug_num}) { + my $location = getbuglocation($param{bug_num},'log.spam'); + my $bug_log = getbugcomponent($param{bug_num},'log.spam',$location); + $self->{name} = $bug_log; + } + $self->_init(); + return $self; +} + + +sub _init { + my $self = shift; + + $self->{spam} = {}; + if (-e $self->{name}) { + open(my $fh,'<',$self->{name}) or + croak "Unable to open bug log spam '$self->{name}' for reading: $!"; + binmode($fh,':encoding(UTF-8)'); + while (<$fh>) { + chomp; + $self->{spam}{$_} = 1; + } + close ($fh); + } + return $self; +} + +=item save + +$self->save(); + +Saves changes to the bug log spam file. + +=cut + +sub save { + my $self = shift; + return unless keys %{$self->{spam}}; + filelock($self->{name}.'.lock'); + open(my $fh,'>',$self->{name}.'.tmp') or + croak "Unable to open bug log spam '$self->{name}.tmp' for writing: $!"; + binmode($fh,':encoding(UTF-8)'); + for my $msgid (keys %{$self->{spam}}) { + print {$fh} $msgid."\n"; + } + close($fh) or croak "Unable to write to '$self->{name}.tmp': $!"; + rename($self->{name}.'.tmp',$self->{name}); + unfilelock(); +} + +=item is_spam + + next if ($spam_log->is_spam('12456@exmaple.com')); + +Returns 1 if this message id confirms that the message is spam + +Returns 0 if this message is not spam + +=cut +sub is_spam { + my ($self,$msgid) = @_; + return 0 if not defined $msgid or not length $msgid; + $msgid =~ s/^<|>$//; + if (exists $self->{spam}{$msgid} and + $self->{spam}{$msgid} + ) { + return 1; + } + return 0; +} + +=item add_spam + + $spam_log->add_spam('123456@example.com'); + +Add a message id to the spam listing. + +You must call C<$self->save()> if you wish the changes to be written out to disk. + +=cut + +sub add_spam { + my ($self,$msgid) = @_; + $msgid =~ s/^<|>$//; + $self->{spam}{$msgid} = 1; +} + +1; + +=back + +=cut + +__END__ + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/MIME.pm b/Debbugs/MIME.pm index adc4566..8644c35 100644 --- a/Debbugs/MIME.pm +++ b/Debbugs/MIME.pm @@ -56,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); diff --git a/Debbugs/Mail.pm b/Debbugs/Mail.pm index 01ae327..e4c8bf7 100644 --- a/Debbugs/Mail.pm +++ b/Debbugs/Mail.pm @@ -49,7 +49,7 @@ use Debbugs::MIME qw(encode_rfc1522); use Debbugs::Config qw(:config); use Params::Validate qw(:types validate_with); use Encode qw(encode is_utf8); -use Debbugs::UTF8 qw(encode_utf8_safely); +use Debbugs::UTF8 qw(encode_utf8_safely convert_to_utf8); use Debbugs::Packages; @@ -334,7 +334,7 @@ sub send_mail_message{ message => {type => SCALAR, }, envelope_from => {type => SCALAR, - optional => 1, + default => $config{envelope_from}, }, recipients => {type => ARRAYREF|UNDEF, optional => 1, @@ -342,7 +342,10 @@ sub send_mail_message{ }, ); my @sendmail_arguments = @{$param{sendmail_arguments}}; - push @sendmail_arguments, '-f', $param{envelope_from} if exists $param{envelope_from}; + push @sendmail_arguments, '-f', $param{envelope_from} if + exists $param{envelope_from} and + defined $param{envelope_from} and + length $param{envelope_from}; my @recipients; @recipients = @{$param{recipients}} if defined $param{recipients} and @@ -447,9 +450,16 @@ sub reply_headers{ my $body = "On $date $who wrote:\n"; my $i = 60; my $b_h; + # Default to UTF-8. + my $charset="utf-8"; ## find the first part which has a defined body handle and appears ## to be text if (defined $entity->bodyhandle) { + my $this_charset = + $entity->head->mime_attr("content-type.charset"); + $charset = $this_charset if + defined $this_charset and + length $this_charset; $b_h = $entity->bodyhandle; } elsif ($entity->parts) { my @parts = $entity->parts; @@ -459,6 +469,11 @@ sub reply_headers{ } if (defined $part->bodyhandle and $part->effective_type =~ /text/) { + my $this_charset = + $part->head->mime_attr("content-type.charset"); + $charset = $this_charset if + defined $this_charset and + length $this_charset; $b_h = $part->bodyhandle; last; } @@ -470,7 +485,7 @@ sub reply_headers{ while (defined($_ = $IO->getline)) { $i--; last if $i < 0; - $body .= '> '. $_; + $body .= '> '. convert_to_utf8($_,$charset); } $IO->close(); }; diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm index d35f269..877466f 100644 --- a/Debbugs/Packages.pm +++ b/Debbugs/Packages.pm @@ -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 @@ 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); @@ -286,7 +287,6 @@ sub binary_to_source{ } } else { - my $found_one_version = 0; for my $version (@versions) { next unless exists $bin->{$version}; if (exists $bin->{$version}{all}) { @@ -582,7 +582,6 @@ sub makesourceversions { arch => 'source', versions => '0.1.1', guess_source => 1, - debug => \$debug, warnings => \$warnings, ); @@ -625,7 +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 --git a/Debbugs/Recipients.pm b/Debbugs/Recipients.pm index f9b2c73..29b92f7 100644 --- a/Debbugs/Recipients.pm +++ b/Debbugs/Recipients.pm @@ -111,8 +111,7 @@ sub add_recipients { } return; } - my ($p, $addmaint); - my $anymaintfound=0; my $anymaintnotfound=0; + my ($addmaint); my $ref = $param{data}{bug_num}; for my $p (splitpackages($param{data}{package})) { $p = lc($p); @@ -182,6 +181,16 @@ sub add_recipients { bug_num => $param{data}{bug_num}, type => 'bcc', ); + } + if (defined $config{cc_all_mails_to_addr} and + length $config{cc_all_mails_to_addr} + ) { + _add_address(recipients => $param{recipients}, + address => $config{cc_all_mails_to}, + reason => "cc_all_mails_to", + bug_num => $param{data}{bug_num}, + type => 'bcc', + ); } if (length $param{data}{owner}) { diff --git a/Debbugs/SOAP.pm b/Debbugs/SOAP.pm index 7508e94..9ed0249 100644 --- a/Debbugs/SOAP.pm +++ b/Debbugs/SOAP.pm @@ -233,7 +233,6 @@ sub get_bug_log{ my %seen_msg_ids; my $current_msg=0; - my $status = {}; my @messages; while (my $record = $log->read_record()) { $current_msg++; diff --git a/Debbugs/Status.pm b/Debbugs/Status.pm index 42dc850..62cba34 100644 --- a/Debbugs/Status.pm +++ b/Debbugs/Status.pm @@ -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); @@ -291,6 +291,17 @@ sub read_bug{ $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; } @@ -335,6 +346,9 @@ 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_space_unique_and_sort, blockedby => $ditch_space_unique_and_sort, # this isn't strictly correct, but we'll split both of them for @@ -444,7 +458,6 @@ data. =cut sub lockreadbugmerge { - my ($bug_num,$location) = @_; my $data = lockreadbug(@_); if (not defined $data) { return (0,undef); @@ -542,7 +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 --git a/Debbugs/Text.pm b/Debbugs/Text.pm index 21bde01..3c34b97 100644 --- a/Debbugs/Text.pm +++ b/Debbugs/Text.pm @@ -64,7 +64,6 @@ use Data::Dumper; our %tt_templates; our %filled_templates; our $safe; -our $hole = Safe::Hole->new({}); our $language; # This function is what is called when someone does include('foo/bar') diff --git a/Debbugs/UTF8.pm b/Debbugs/UTF8.pm index c4067f5..230ab79 100644 --- a/Debbugs/UTF8.pm +++ b/Debbugs/UTF8.pm @@ -179,12 +179,9 @@ sub convert_to_utf8 { # if there's an à (0xC3), it's probably something # horrible, and we shouldn't try to convert it. if (defined $call_back_data and $call_back_data !~ /\x{C3}/) { - # this warning produces far too much useless output; elminating it - # warn "failed to convert to utf8 (charset: $charset, data: $data), but succeeded with ISO8859-1: ".encode_utf8($call_back_data); return $call_back_data; } } - warn "failed to convert to utf8 (charset: $charset, data: $data)"; # Fallback to encode, which will probably also fail. return __fallback_convert_to_utf8($data,$charset); } diff --git a/Debbugs/User.pm b/Debbugs/User.pm index c25b35a..2457e54 100644 --- a/Debbugs/User.pm +++ b/Debbugs/User.pm @@ -86,7 +86,7 @@ use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); use Exporter qw(import); use Debbugs::Config qw(:config); -use List::Util qw(min); +use List::AllUtils qw(min); use Carp; use IO::File; diff --git a/Makefile b/Makefile index 3e6dd58..8114d0b 100644 --- a/Makefile +++ b/Makefile @@ -24,21 +24,23 @@ install_exec := install -m755 -p install_data := install -m644 -p PERL ?= /usr/bin/perl +# Some tests need to run under an UTF-8 locale. +UTF8_LOCALE ?= C.UTF-8 -all: build test +all: build build: $(PERL) Makefile.PL $(MAKE) -f Makefile.perl test: - $(PERL) -MTest::Harness -I. -e 'runtests(glob(q(t/*.t)))' + LC_ALL=$(UTF8_LOCALE) $(PERL) -MTest::Harness -I. -e 'runtests(glob(q(t/*.t)))' test_%: t/%.t - $(PERL) -MTest::Harness -I. -e 'runtests(q($<))' + LC_ALL=$(UTF8_LOCALE) $(PERL) -MTest::Harness -I. -e 'runtests(q($<))' testcover: - PERL5LIB=t/cover_lib/:. cover -test + LC_ALL=$(UTF8_LOCALE) PERL5LIB=t/cover_lib/:. cover -test clean: if [ -e Makefile.perl ]; then \ @@ -47,10 +49,8 @@ clean: install: install_mostfiles # install basic debbugs documentation - $(install_data) COPYING UPGRADE README debian/README.mail $(doc_dir) - - # configure debbugs - $(sbin_dir)/debbugsconfig + $(install_data) COPYING UPGRADE README.md debian/README.mail $(doc_dir) + $(MAKE) -f Makefile.perl install DESTDIR=$(DESTDIR) install_mostfiles: # create the directories if they aren't there diff --git a/Makefile.PL b/Makefile.PL index 0063970..1593964 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -3,10 +3,62 @@ use ExtUtils::MakeMaker; WriteMakefile(FIRST_MAKEFILE => 'Makefile.perl', - PMLIBDIRS => ['Debbugs','Mail'], - EXE_FILES => ['bin/local-debbugs', - 'bin/add_bug_to_estraier', - ], - NAME => 'Debbugs', - VERSION => '2.4.2', - ); + PMLIBDIRS => ['Debbugs','Mail'], + EXE_FILES => ['bin/local-debbugs', + 'bin/add_bug_to_estraier', + ], + NAME => 'Debbugs', + PREREQ_PM => {'AptPkg::Version' => 0, + 'CGI::Alert' => 0, + 'CGI::Simple' => 0, + 'Config::Simple' => 0, + 'Data::Dumper' => 0, + 'Digest::MD5' => 0, + 'ExtUtils::MakeMaker' => 0, + 'File::Basename' => 0, + 'File::Copy' => 0, + 'File::Find' => 0, + 'File::LibMagic' => 0, + 'File::Path' => 0, + 'File::stat' => 0, + 'File::Temp' => 0, + 'Getopt::Long' => 0, + 'HTML::Entities' => 0, + 'HTTP::Server::Simple' => 0, + 'HTTP::Status' => 0, + 'IO::File' => 0, + 'IO::Handle' => 0, + 'IO::InnerFile' => 0, + 'IO::Scalar' => 0, + 'IPC::Open2' => 0, + 'IPC::Open3' => 0, + 'IPC::Run' => 0, + 'Libravatar::URL' => 0, + 'List::AllUtils' => 0, + 'LWP::UserAgent' => 0, + 'Mail::Address' => 0, + 'Mail::CrossAssassin' => 0, + 'Mail::RFC822::Address' => 0, + 'Mail::SpamAssassin' => 0, + 'MIME::Decoder' => 0, + 'MIME::Parser' => 0, + 'MIME::Words' => 0, + 'MIME::Words::encode_mimewords' => 0, + 'Params::Validate' => 0, + 'Pod::Usage' => 0, + 'Safe::Hole' => 0, + 'Scalar::Util' => 0, + 'SOAP::Lite' => 0, + 'SOAP::Transport::HTTP' => 0, + 'Sys::Hostname' => 0, + 'Test::More' => 0, + 'Test::Pod' => 0, + 'Test::WWW::Mechanize' => 0, + 'Text::Iconv' => 0, + 'Text::Template' => 0, + 'threads::shared' => 0, + 'Time::HiRes' => 0, + 'URI::Escape' => 0, + }, + VERSION => '2.4.2', + ); diff --git a/bin/debbugs-spamscan-log b/bin/debbugs-spamscan-log new file mode 100755 index 0000000..08e7526 --- /dev/null +++ b/bin/debbugs-spamscan-log @@ -0,0 +1,189 @@ +#! /usr/bin/perl +# debbugs-spamscan-log is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version, at your +# option. See the file README and COPYING for more information. +# Copyright 2012 by Don Armstrong . + + +use warnings; +use strict; + +use Getopt::Long qw(:config no_ignore_case); +use Pod::Usage; + +=head1 NAME + +debbugs-spamscan-log -- Scan log files for spam and populate nnn.log.spam + +=head1 SYNOPSIS + +debbugs-spamscan-log [options] bugnumber [[bugnumber2]..] + + Options: + --spool-dir debbugs spool directory + --debug, -d debugging level (Default 0) + --help, -h display this help + --man, -m display manual + +=head1 OPTIONS + +=over + +=item B<--spool-dir> + +Debbugs spool directory; defaults to the value configured in the +debbugs configuration file. + +=item B<--debug, -d> + +Debug verbosity. + +=item B<--help, -h> + +Display brief useage information. + +=item B<--man, -m> + +Display this manual. + +=back + +=head1 EXAMPLES + +Rebuild the index.db for db-h. + + debbugs-spamscan-log; + +Rebuild the index.db for archive + + debbugs-spamscan-log archive; + + +=cut + + +use vars qw($DEBUG); + +use Debbugs::Log qw(record_regex); +use Debbugs::Log::Spam; +use Debbugs::Config qw(:config); +use IPC::Open3 qw(open3); + +my %options = + (debug => 0, + help => 0, + man => 0, + verbose => 0, + quiet => 0, + quick => 0, + spamc => 'spamc', + spamc_opts => [], + ); + + +GetOptions(\%options, + 'quick|q', + 'service|s', + 'sysconfdir|c', + 'spool_dir|spool-dir=s', + 'spamc=s', + 'spamc_opts|spamc-opts=s@', + 'debug|d+','help|h|?','man|m'); + +pod2usage() if $options{help}; +pod2usage({verbose=>2}) if $options{man}; + +$DEBUG = $options{debug}; + +my @USAGE_ERRORS; +$options{verbose} = $options{verbose} - $options{quiet}; + +if (not @ARGV) { + push @USAGE_ERRORS, + "You must provide a bug number to examine\n"; +} + +pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS; + +if (exists $options{spool_dir} and defined $options{spool_dir}) { + $config{spool_dir} = $options{spool_dir}; +} +chdir($config{spool_dir}) or die "chdir $config{spool_dir} failed: $!"; + +for my $bug_num (@ARGV) { + my $log = Debbugs::Log->new(bug_num => $bug_num) or + die "Unable to open bug log for $bug_num"; + my $spam = Debbugs::Log::Spam->new(bug_num => $bug_num) or + die "Unable to open bug log spam for $bug_num"; + + my %seen_msgids; + while (my $record = $log->read_record()) { + next if $record->{type} eq 'html'; + next if $record->{type} eq 'autocheck'; + my ($msg_id) = record_regex($record, + qr/^Message-Id:\s+<(.+)>/mi); + next unless defined $msg_id; + if ($msg_id =~ /$config{email_domain}$/) { + print STDERR "skipping $msg_id\n" if $DEBUG; + next; + } + print STDERR "examining $msg_id: " if $DEBUG; + if ($seen_msgids{$msg_id}) { + print STDERR "already seen\n" if $DEBUG; + next; + } + $seen_msgids{$msg_id}=1; + if ($spam->is_spam($msg_id)) { + print STDERR "already spam\n" if $DEBUG; + next; + } + my $is_spam; + eval { + my ($spamc,$child_out); + my $old_sig = $SIG{"PIPE"}; + $SIG{"PIPE"} = sub { + die "SIGPIPE in child for some reason"; + }; + my $childpid = + open3($spamc,$child_out,0, + $options{spamc},'-E',@{$options{spamc_opts}}) or + die "Unable to fork spamc: $!"; + if (not $childpid) { + die "Unable to fork spamc"; + } + print {$spamc} $record->{text}; + close($spamc) or die "Unable to close spamc: $!"; + waitpid($childpid,0); + if ($DEBUG) { + print STDERR "[$?;".($? >> 8)."] "; + print STDERR map {s/\n//; $_ } <$child_out>; + print STDERR " "; + } + close($child_out); + $SIG{"PIPE"} = $old_sig; + if ($? >> 8) { + $is_spam = 1; + } + }; + if ($@) { + print STDERR "processing of $msg_id failed [$@]\n"; + } else { + if ($is_spam) { + print STDERR "it's spam\n" if $DEBUG; + $spam->add_spam($msg_id); + } + else { + print STDERR "it's ham\n" if $DEBUG; + } + } + } + $spam->save(); +} + + +__END__ + +# Local Variables: +# cperl-indent-level: 4 +# indent-tabs-mode: nil +# End: diff --git a/bin/local-debbugs b/bin/local-debbugs index b75d55f..0223da1 100755 --- a/bin/local-debbugs +++ b/bin/local-debbugs @@ -143,7 +143,7 @@ my %option_defaults = (port => 8080, ); GetOptions(\%options, - 'daemon|D','show|s','search|select|S','mirror|M', 'stop', + 'daemon|D','show|s','search|select|S','mirror|M', 'stop|exit|quit', 'detach!', 'css=s','cgi_bin|cgi-bin|cgi=s', 'verbose|v+','quiet|q+', @@ -158,7 +158,7 @@ $DEBUG = $options{debug}; my @USAGE_ERRORS; if (1 != grep {exists $options{$_}} qw(daemon show search mirror stop)) { - push @USAGE_ERRORS,"You must pass one (and only one) of --daemon --show --search or --mirror"; + push @USAGE_ERRORS,"You must pass one (and only one) of --daemon --show --search --mirror or --stop"; } $options{verbose} = $options{verbose} - $options{quiet}; @@ -183,6 +183,24 @@ if ($options{daemon}) { print STDERR "Unable to determine if daemon is running: $!\n"; exit 1; } + my $conf = IO::File->new($options{mirror_location}.'/debbugs_config_local','w') or + die "Unable to open $options{mirror_location}/debbugs_config_local for writing: $!"; + print {$conf} <<"EOF"; +\$gConfigDir = "$options{mirror_location}"; +\$gSpoolDir = "$options{mirror_location}"; +\$gWebHost = 'localhost:$options{port}'; +\$gPackageSource = ''; +\$gPseudoDescFile = ''; +\$gPseudoMaintFile = ''; +\$gMaintainerFile = ''; +\$gMaintainerFileOverride = ''; +\$config{source_maintainer_file} = ''; +\$config{source_maintainer_file_override} = ''; +\$gProject = 'Local Debbugs'; +1; +EOF + close $conf; + $ENV{DEBBUGS_CONFIG_FILE} = $options{mirror_location}.'/debbugs_config_local'; # ok, now lets daemonize # XXX make sure that all paths have been turned into absolute @@ -206,7 +224,7 @@ if ($options{daemon}) { package local_debbugs::server; use IO::File; use HTTP::Server::Simple; - use base qw(HTTP::Server::Simple::CGI); + use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment); sub net_server { return 'Net::Server::Fork'; @@ -222,6 +240,7 @@ if ($options{daemon}) { sub handle_request { my ($self,$cgi) = @_; + $ENV{DEBBUGS_CONFIG_FILE} = $options{mirror_location}.'/debbugs_config_local'; my $base_uri = 'http://'.$cgi->virtual_host; if ($cgi->virtual_port ne 80) { $base_uri .= ':'.$cgi->virtual_port; @@ -261,10 +280,28 @@ if ($options{daemon}) { } elsif ($path =~ m{^/?cgi(?:-bin)?/((?:(?:bug|pkg)report|version)\.cgi)}) { # dispatch to pkgreport.cgi - print "HTTP/1.1 200 OK\n"; - exec("$options{cgi_bin}/$1") or - die "Unable to execute $options{cgi_bin}/$1"; - } + #print "HTTP/1.1 200 OK\n"; + open(my $fh,'-|',"$options{cgi_bin}/$1") or + die "Unable to execute $options{cgi_bin}/$1"; + my $status; + my $cache = ''; + while (<$fh>) { + if (/Status: (\d+\s+.+?)\n?$/) { + $status = $1; + print "HTTP/1.1 $status\n"; + print STDERR "'$status'\n"; + last; + } + $cache .= $_; + if (/^$/) { + print "HTTP/1.1 200 OK\n"; + last; + } + } + print $cache; + print <$fh>; + close($fh) or die "Unable to close"; + } elsif ($path =~ m{^/?css/bugs.css}) { my $fh = IO::File->new($options{css},'r') or die "Unable to open $options{css} for reading: $!"; @@ -438,9 +475,8 @@ sub run_rsync{ ); my ($output,$error) = ('',''); my $h = IPC::Run::start(['rsync',@{$param{options}}], - \undef,\$output,\$error); + \undef,$param{log},$param{log}); while ($h->pump) { - print {$param{log}} $output,$error; #print {$param{debug}} $error if defined $param{debug}; } $h->finish(); diff --git a/cgi/.cvsignore b/cgi/.cvsignore deleted file mode 100644 index 8c29d42..0000000 --- a/cgi/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -*.out -*.trace diff --git a/cgi/bugreport.cgi b/cgi/bugreport.cgi index 9b445ce..7d3911a 100755 --- a/cgi/bugreport.cgi +++ b/cgi/bugreport.cgi @@ -19,19 +19,18 @@ use Debbugs::Config qw(:globals :text :config); # for read_log_records use Debbugs::Log qw(:read); -use Debbugs::CGI qw(:url :html :util :cache); +use Debbugs::Log::Spam; +use Debbugs::CGI qw(:url :html :util :cache :usertags); use Debbugs::CGI::Bugreport qw(:all); use Debbugs::Common qw(buglog getmaintainers make_list bug_status); use Debbugs::Packages qw(getpkgsrc); use Debbugs::Status qw(splitpackages split_status_fields get_bug_status isstrongseverity); -use Debbugs::User; - use Scalar::Util qw(looks_like_number); use Debbugs::Text qw(:templates); -use List::Util qw(max); +use List::AllUtils qw(max); use CGI::Simple; @@ -60,8 +59,8 @@ my %param = cgi_parameters(query => $q, ); # This is craptacular. -my $ref = $param{bug} or quitcgi("No bug number"); -$ref =~ /(\d+)/ or quitcgi("Invalid bug number"); +my $ref = $param{bug} or quitcgi("No bug number", '400 Bad Request'); +$ref =~ /(\d+)/ or quitcgi("Invalid bug number", '400 Bad Request'); $ref = $1; my $short = "#$ref"; my ($msg) = $param{msg} =~ /^(\d+)$/ if exists $param{msg}; @@ -129,12 +128,12 @@ if (not (($mbox and not $mbox_status_message) or ## Identify the users required for my $user (map {split /[\s*,\s*]+/} make_list($param{users}||[])) { next unless length($user); - push @dependent_files,Debbugs::User::usertag_flie_from_email($user); + push @dependent_files,Debbugs::User::usertag_file_from_email($user); } if (defined $param{usertag}) { for my $usertag (make_list($param{usertag})) { my ($user, $tag) = split /:/, $usertag, 2; - push @dependent_files,Debbugs::User::usertag_flie_from_email($user); + push @dependent_files,Debbugs::User::usertag_file_from_email($user); } } $etag = @@ -146,7 +145,12 @@ $etag = ], ); if (not $etag) { - print $q->header(-status => 304); + print $q->header(-status => 304, + -cache_control => 'public, max-age=600', + -etag => $etag, + -charset => 'utf-8', + -content_type => 'text/html', + ); print "304: Not modified\n"; exit 0; } @@ -156,6 +160,7 @@ if ($q->request_method() eq 'HEAD' and not defined($att) and not $mbox) { print $q->header(-status => 200, -cache_control => 'public, max-age=600', -etag => $etag, + -charset => 'utf-8', -content_type => 'text/html', ); exit 0; @@ -179,18 +184,6 @@ if (defined $param{usertag}) { } } - -my $buglogfh; -if ($buglog =~ m/\.gz$/) { - my $oldpath = $ENV{'PATH'}; - $ENV{'PATH'} = '/bin:/usr/bin'; - $buglogfh = IO::File->new("zcat $buglog |") or quitcgi("open log for $ref: $!"); - $ENV{'PATH'} = $oldpath; -} else { - $buglogfh = IO::File->new($buglog,'r') or quitcgi("open log for $ref: $!"); -} - - my %status; if ($need_status) { %status = %{split_status_fields(get_bug_status(bug=>$ref, @@ -199,14 +192,14 @@ if ($need_status) { } my @records; +my $spam; eval{ - @records = read_log_records(logfh => $buglogfh,inner_file => 1); + @records = read_log_records(bug_num => $ref,inner_file => 1); + $spam = Debbugs::Log::Spam->new(bug_num => $ref); }; if ($@) { quitcgi("Bad bug log for $gBug $ref. Unable to read records: $@"); } -undef $buglogfh; - my $log=''; my $msg_num = 0; @@ -277,6 +270,8 @@ END $record_wanted_anyway = 1 if record_regex($record,qr/^Received: \(at control\)/); next if not $boring and not $record->{type} eq $wanted_type and not $record_wanted_anyway and @records > 1; $seen_message_ids{$msg_id} = 1 if defined $msg_id; + # skip spam messages if we're outputting more than one message + next if @records > 1 and $spam->is_spam($msg_id); my @lines; if ($record->{inner_file}) { push @lines, $record->{fh}->getline; @@ -331,6 +326,10 @@ else { \%seen_msg_ids, trim_headers => $trim_headers, avatars => $avatars, + terse => $terse, + # if we're only looking at one record, allow + # spam to be output + spam => (@records > 1)?$spam:undef, ); } } @@ -416,7 +415,9 @@ $status{blockedby_array} = []; if (@blockedby && $status{"pending"} ne 'fixed' && ! length($status{done})) { for my $b (@blockedby) { my %s = %{get_bug_status($b)}; - next if $s{"pending"} eq 'fixed' || length $s{done}; + next if (defined $s{pending} and + $s{"pending"} eq 'fixed') or + length $s{done}; push @{$status{blockedby_array}},{bug_num => $b, subject => $s{subject}, status => \%s}; } } @@ -464,3 +465,10 @@ print fill_in_template(template => 'cgi/bugreport', '&maybelink' => \&Debbugs::CGI::maybelink, }, ); + +__END__ + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/cgi/bugs-fetch2.pl b/cgi/bugs-fetch2.pl deleted file mode 100644 index 496c092..0000000 --- a/cgi/bugs-fetch2.pl +++ /dev/null @@ -1,72 +0,0 @@ -#!/usr/bin/perl - -require './common.pl'; - -require '/etc/debbugs/config'; - -%map= ($gMirrors); - -my %in = readparse(); - -if ($in{'type'} eq 'ref') { - $_= $in{'ref'}; - s/^\s+//; s/^\#//; s/^\s+//; s/^0*//; s/\s+$//; - - if (m/\D/ || !m/\d/) { - print <Bug number not numeric - -

Invalid input to specific bug fetch form

- -You must type a number, being the bug reference number. -There should be no nondigits in your entry. - -END - exit(0); - } - $suburl= "bugreport.cgi?bug=$_"; -} elsif ($in{'type'} eq 'package') { - $_= $in{'package'}; - s/^\s+//; s/\s+$//; y/A-Z/a-z/; - if (m/^[^0-9a-z]/ || m/[^-+.0-9a-z]/) { - print <Package name contains invalid characters - -

Invalid input to package buglist fetch form

- -You must type a package name. Package names start with a letter -or digit and contain only letters, digits and the characters -- + . (hyphen, plus, full stop). - -END - exit(0); - } - $suburl= "pkgreport.cgi?pkg=$_"; -} else { - print <here. - -(If this link does not work then the bug or package does not exist in -the tracking system any more, or does not yet, or never did.) -END - -exit(0); diff --git a/cgi/common.pl b/cgi/common.pl deleted file mode 100644 index 05b8941..0000000 --- a/cgi/common.pl +++ /dev/null @@ -1,702 +0,0 @@ -#!/usr/bin/perl -w - -use DB_File; -use Fcntl qw/O_RDONLY/; -use Mail::Address; -use MLDBM qw(DB_File Storable); -use POSIX qw/ceil/; - -use URI::Escape; - -use Debbugs::Config qw(:globals :text); -$config_path = '/etc/debbugs'; -$lib_path = '/usr/lib/debbugs'; -#require "$lib_path/errorlib"; - -use Debbugs::Packages qw(:versions :mapping); -use Debbugs::Versions; -use Debbugs::MIME qw(decode_rfc1522); -use Debbugs::Common qw(:util); -use Debbugs::Status qw(:status :read :versions); -use Debbugs::CGI qw(:all); -use Debbugs::Bugs qw(count_bugs); - -$MLDBM::RemoveTaint = 1; - -my %common_bugusertags; -my $common_mindays = 0; -my $common_maxdays = -1; -my $common_archive = 0; -my $common_repeatmerged = 1; -my %common_include = (); -my %common_exclude = (); -my $common_raw_sort = 0; -my $common_bug_reverse = 0; - -my $common_leet_urls = 0; - -my %common_reverse = ( - 'pending' => 0, - 'severity' => 0, -); -my %common = ( - 'show_list_header' => 1, - 'show_list_footer' => 1, -); - -sub exact_field_match { - my ($field, $values, $status) = @_; - my @values = @$values; - my @ret = grep {$_ eq $status->{$field} } @values; - $#ret != -1; -} -sub contains_field_match { - my ($field, $values, $status) = @_; - foreach my $data (@$values) { - return 1 if (index($status->{$field}, $data) > -1); - } - return 0; -} - -sub detect_user_agent { - my $userAgent = $ENV{HTTP_USER_AGENT}; - return { 'name' => 'unknown' } unless defined $userAgent; - return { 'name' => 'links' } if ( $userAgent =~ m,^ELinks,); - return { 'name' => 'lynx' } if ( $userAgent =~ m,^Lynx,); - return { 'name' => 'wget' } if ( $userAgent =~ m,^Wget,); - return { 'name' => 'gecko' } if ( $userAgent =~ m,^Mozilla.* Gecko/,); - return { 'name' => 'ie' } if ( $userAgent =~ m,^.*MSIE.*,); - return { 'name' => 'unknown' }; -} - -my %field_match = ( - 'subject' => \&contains_field_match, - 'tags' => sub { - my ($field, $values, $status) = @_; - my %values = map {$_=>1} @$values; - foreach my $t (split /\s+/, $status->{$field}) { - return 1 if (defined $values{$t}); - } - return 0; - }, - 'severity' => \&exact_field_match, - 'pending' => \&exact_field_match, - 'originator' => \%contains_field_match, - 'forwarded' => \%contains_field_match, - 'owner' => \%contains_field_match, -); -my @common_grouping = ( 'severity', 'pending' ); -my %common_grouping_order = ( - 'pending' => [ qw( pending forwarded pending-fixed fixed done absent ) ], - 'severity' => \@gSeverityList, -); -my %common_grouping_display = ( - 'pending' => 'Status', - 'severity' => 'Severity', -); -my %common_headers = ( - 'pending' => { - "pending" => "outstanding", - "pending-fixed" => "pending upload", - "fixed" => "fixed in NMU", - "done" => "resolved", - "forwarded" => "forwarded to upstream software authors", - "absent" => "not applicable to this version", - }, - 'severity' => \%gSeverityDisplay, -); - -my $common_version; -my $common_dist; -my $common_arch; - -my $debug = 0; -my $use_bug_idx = 0; -my %bugidx; - -sub array_option($) { - my ($val) = @_; - my @vals; - @vals = ( $val ) if (ref($val) eq "" && $val ); - @vals = ( $$val ) if (ref($val) eq "SCALAR" && $$val ); - @vals = @{$val} if (ref($val) eq "ARRAY" ); - return @vals; -} - -sub filter_include_exclude($\%) { - my ($val, $filter_map) = @_; - my @vals = array_option($val); - my @data = map { - if (/^([^:]*):(.*)$/) { if ($1 eq 'subj') { ['subject', $2]; } else { [$1, $2] } } else { ['tags', $_] } - } split /[\s,]+/, join ',', @vals; - foreach my $data (@data) { - &quitcgi("Invalid filter key: '$data->[0]'") if (!exists($field_match{$data->[0]})); - push @{$filter_map->{$data->[0]}}, $data->[1]; - } -} - -sub filter_option($$\%) { - my ($key, $val, $filter_map) = @_; - my @vals = array_option($val); - foreach $val (@vals) { - push @{$filter_map->{$key}}, $val; - } -} - -sub set_option { - my ($opt, $val) = @_; - if ($opt eq "use-bug-idx") { - $use_bug_idx = $val; - if ( $val ) { - $common_headers{pending}{open} = $common_headers{pending}{pending}; - my $bugidx = tie %bugidx, MLDBM => "$gSpoolDir/realtime/bug.idx", O_RDONLY - or quitcgi( "$0: can't open $gSpoolDir/realtime/bug.idx ($!)\n" ); - $bugidx->RemoveTaint(1); - } else { - untie %bugidx; - } - } - if ($opt =~ m/^show_list_(foot|head)er$/) { $common{$opt} = $val; } - if ($opt eq "archive") { $common_archive = $val; } - if ($opt eq "repeatmerged") { $common_repeatmerged = $val; } - if ($opt eq "exclude") { - filter_include_exclude($val, %common_exclude); - } - if ($opt eq "include") { - filter_include_exclude($val, %common_include); - } - if ($opt eq "raw") { $common_raw_sort = $val; } - if ($opt eq "bug-rev") { $common_bug_reverse = $val; } - if ($opt eq "pend-rev") { $common_reverse{pending} = $val; } - if ($opt eq "sev-rev") { $common_reverse{severity} = $val; } - if ($opt eq "pend-exc") { - filter_option('pending', $val, %common_exclude); - } - if ($opt eq "pend-inc") { - filter_option('pending', $val, %common_include); - } - if ($opt eq "sev-exc") { - filter_option('severity', $val, %common_exclude); - } - if ($opt eq "sev-inc") { - filter_option('severity', $val, %common_include); - } - if ($opt eq "version") { $common_version = $val; } - if ($opt eq "dist") { $common_dist = $val; } - if ($opt eq "arch") { $common_arch = $val; } - if ($opt eq "maxdays") { $common_maxdays = $val; } - if ($opt eq "mindays") { $common_mindays = $val; } - if ($opt eq "bugusertags") { %common_bugusertags = %{$val}; } -} - -sub readparse { - my ($key, $val, %ret); - my $in = ""; - if ($#ARGV >= 0) { - $in .= ";" . join("&", map { s/&/%26/g; s/;/%3b/g; $_ } @ARGV); - } - if (defined $ENV{"QUERY_STRING"} && $ENV{"QUERY_STRING"} ne "") { - $in .= ";" . $ENV{QUERY_STRING}; - } - if (defined $ENV{"REQUEST_METHOD"} && $ENV{"REQUEST_METHOD"} eq "POST" - && defined $ENV{"CONTENT_TYPE"} - && $ENV{"CONTENT_TYPE"} eq "application/x-www-form-urlencoded") - { - my $inx; - read(STDIN,$inx,$ENV{CONTENT_LENGTH}); - $in .= ";" . $inx; - } - return unless ($in ne ""); - - if (defined $ENV{"HTTP_COOKIE"}) { - my $x = $ENV{"HTTP_COOKIE"}; - $x =~ s/;\s+/;/g; - $in = "$x;$in"; - } - $in =~ s/&/;/g; - $in =~ s/;;+/;/g; $in =~ s/^;//; $in =~ s/;$//; - foreach (split(/[&;]/,$in)) { - s/\+/ /g; - ($key, $val) = split(/=/,$_,2); - $key=~s/%(..)/pack("c",hex($1))/ge; - $val=~s/%(..)/pack("c",hex($1))/ge; - if ( exists $ret{$key} ) { - if ( !exists $ret{"&$key"} ) { - $ret{"&$key"} = [ $ret{$key} ]; - } - push @{$ret{"&$key"}},$val; - } - $ret{$key}=$val; - } - -$debug = 1 if (defined $ret{"debug"} && $ret{"debug"} eq "aj"); - - $common_leet_urls = 1 - if (defined $ret{"leeturls"} && $ret{"leeturls"} eq "yes"); - - return %ret; -} - -# Generate a comma-separated list of HTML links to each package given in -# $pkgs. $pkgs may be empty, in which case an empty string is returned, or -# it may be a comma-separated list of package names. -sub htmlpackagelinks { - return htmlize_packagelinks(@_); -} - -# Generate a comma-separated list of HTML links to each address given in -# $addresses, which should be a comma-separated list of RFC822 addresses. -# $urlfunc should be a reference to a function like mainturl or submitterurl -# which returns the URL for each individual address. -sub htmladdresslinks { - htmlize_addresslinks(@_); -} - -# Generate a comma-separated list of HTML links to each maintainer given in -# $maints, which should be a comma-separated list of RFC822 addresses. -sub htmlmaintlinks { - my ($prefixfunc, $maints) = @_; - return htmladdresslinks($prefixfunc, \&mainturl, $maints); -} - -sub htmlindexentry { - my $ref = shift; - my %status = %{getbugstatus($ref)}; - return htmlindexentrystatus(%status) if (%status); - return ""; -} - -sub htmlindexentrystatus { - my $s = shift; - my %status = %{$s}; - - my $result = ""; - - if ($status{severity} eq 'normal') { - $showseverity = ''; - } elsif (isstrongseverity($status{severity})) { - $showseverity = "Severity: $status{severity};\n"; - } else { - $showseverity = "Severity: $status{severity};\n"; - } - - $result .= htmlpackagelinks($status{"package"}, 1); - - my $showversions = ''; - if (@{$status{found_versions}}) { - my @found = @{$status{found_versions}}; - local $_; - s{/}{ } foreach @found; - $showversions .= join ', ', map htmlsanit($_), @found; - } - if (@{$status{fixed_versions}}) { - $showversions .= '; ' if length $showversions; - $showversions .= 'fixed: '; - my @fixed = @{$status{fixed_versions}}; - local $_; - s{/}{ } foreach @fixed; - $showversions .= join ', ', map htmlsanit($_), @fixed; - } - $result .= " ($showversions)" if length $showversions; - $result .= ";\n"; - - $result .= $showseverity; - $result .= htmladdresslinks("Reported by: ", \&submitterurl, - $status{originator}); - $result .= ";\nOwned by: " . htmlsanit($status{owner}) - if length $status{owner}; - $result .= ";\nTags: " - . htmlsanit(join(", ", sort(split(/\s+/, $status{tags})))) - . "" - if (length($status{tags})); - my @merged= split(/ /,$status{mergedwith}); - my $mseparator= ";\nmerged with "; - for my $m (@merged) { - $result .= $mseparator."#$m"; - $mseparator= ", "; - } - - if (length($status{done})) { - $result .= ";\nDone: " . htmlsanit($status{done}); - $days = ceil($gRemoveAge - -M buglog($status{id})); - if ($days >= 0) { - $result .= ";\nWill be archived:" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ); - } else { - $result .= ";\nArchived"; - } - } - - unless (length($status{done})) { - if (length($status{forwarded})) { - $result .= ";\nForwarded to " - . maybelink($status{forwarded}); - } - my $daysold = int((time - $status{date}) / 86400); # seconds to days - if ($daysold >= 7) { - my $font = ""; - my $efont = ""; - $font = "em" if ($daysold > 30); - $font = "strong" if ($daysold > 60); - $efont = "" if ($font); - $font = "<$font>" if ($font); - - my $yearsold = int($daysold / 365); - $daysold -= $yearsold * 365; - - $result .= ";\n $font"; - my @age; - push @age, "1 year" if ($yearsold == 1); - push @age, "$yearsold years" if ($yearsold > 1); - push @age, "1 day" if ($daysold == 1); - push @age, "$daysold days" if ($daysold > 1); - $result .= join(" and ", @age); - $result .= " old$efont"; - } - } - - $result .= "."; - - return $result; -} - -sub urlargs { - my $args = ''; - $args .= ";archive=yes" if $common_archive; - $args .= ";repeatmerged=no" unless $common_repeatmerged; - $args .= ";mindays=${common_mindays}" unless $common_mindays == 0; - $args .= ";maxdays=${common_maxdays}" unless $common_maxdays == -1; - $args .= ";version=$common_version" if defined $common_version; - $args .= ";dist=$common_dist" if defined $common_dist; - $args .= ";arch=$common_arch" if defined $common_arch; - return $args; -} - -sub pkgurl { pkg_url(pkg => $_[0] || ""); } -sub srcurl { pkg_url(src => $_[0] || ""); } -sub tagurl { pkg_url(tag => $_[0] || ""); } - -sub pkg_etc_url { - my $ref = shift; - my $code = shift; - if ($common_leet_urls) { - $code = "package" if ($code eq "pkg"); - $code = "source" if ($code eq "src"); - return urlsanit("/x/$code/$ref"); - } else { - my $addurlargs = shift || 1; - my $params = "$code=$ref"; - $params .= urlargs() if $addurlargs; - return urlsanit("pkgreport.cgi" . "?" . $params); - } -} - -sub urlsanit { - my $url = shift; - $url =~ s/%/%25/g; - $url =~ s/#/%23/g; - $url =~ s/\+/%2b/g; - my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot'); - $url =~ s/([<>&"])/\&$saniarray{$1};/g; - return $url; -} - -sub htmlsanit { - my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot'); - my $in = shift || ""; - $in =~ s/([<>&"])/\&$saniarray{$1};/g; - return $in; -} - -sub bugurl { - my $ref = shift; - my $params = "bug=$ref"; - my $filename = ''; - - if ($common_leet_urls) { - my $msg = ""; - my $mbox = ""; - my $att = ""; - foreach my $val (@_) { - $mbox = "/mbox" if ($val eq "mbox"); - $msg = "/$1" if ($val =~ /^msg=([0-9]+)/); - $att = "/$1" if ($val =~ /^att=([0-9]+)/); - $filename = "/$1" if ($val =~ /^filename=(.*)$/); - } - my $ext = ""; - if ($mbox ne "") { - $ext = $mbox; - } elsif ($att ne "") { - $ext = "$att$filename"; - } - return urlsanit("/x/$ref$msg$ext"); - } else { - foreach my $val (@_) { - $params .= ";mbox=yes" if ($val eq "mbox"); - $params .= ";msg=$1" if ($val =~ /^msg=([0-9]+)/); - $params .= ";att=$1" if ($val =~ /^att=([0-9]+)/); - $filename = $1 if ($val =~ /^filename=(.*)$/); - $params .= ";archive=yes" if (!$common_archive && $val =~ /^archive.*$/); - } - $params .= ";archive=yes" if ($common_archive); - $params .= ";repeatmerged=no" unless ($common_repeatmerged); - - my $pathinfo = ''; - $pathinfo = '/'.uri_escape($filename) if $filename ne ''; - - return urlsanit("bugreport.cgi" . $pathinfo . "?" . $params); - } -} - -sub dlurl { bugurl(@_); } -sub mboxurl { return bugurl($ref, "mbox"); } - -sub allbugs { - return @{getbugs(sub { 1 })}; -} - -sub bugmatches { - my ($hash, $status) = @_; - foreach my $key( keys( %$hash ) ) { - my $value = $hash->{$key}; - my $sub = $field_match{$key}; - return 1 if ($sub->($key, $value, $status)); - } - return 0; -} -sub bugfilter { - my ($bug, $status,$seen_merged,$common_include,$common_exclude,$repeat_merged,) = @_; - #our (%seenmerged); - if ($common_include) { - return 1 if (!bugmatches($common_include, $status)); - } - if ($common_exclude) { - return 1 if (bugmatches($common_exclude, $status)); - } - my @merged = sort {$a<=>$b} $bug, split(/ /, $status{mergedwith}); - my $daysold = int((time - $status{date}) / 86400); # seconds to days - return 1 unless ($common_mindays <= $daysold); - return 1 unless ($common_maxdays == -1 || $daysold <= $common_maxdays); - return 1 unless ($common_repeatmerged || !$seenmerged{$merged[0]}); - $seenmerged{$merged[0]} = 1; - return 0; -} - -sub htmlizebugs { - $b = $_[0]; - my @bugs = @$b; - my $anydone = 0; - - my @status = (); - my %count; - my $header = ''; - my $footer = ''; - - if (@bugs == 0) { - return "

No reports found!

\n"; - } - - if ( $common_bug_reverse ) { - @bugs = sort {$b<=>$a} @bugs; - } else { - @bugs = sort {$a<=>$b} @bugs; - } - my %seenmerged; - foreach my $bug (@bugs) { - my %status = %{getbugstatus($bug)}; - next unless %status; - next if bugfilter($bug, %status); - - my $html = sprintf "
  • #%d: %s\n
    ", - bugurl($bug), $bug, htmlsanit($status{subject}); - $html .= htmlindexentrystatus(\%status) . "\n"; - my $key = join( '_', map( {$status{$_}} @common_grouping ) ); - $section{$key} .= $html; - $count{"_$key"}++; - foreach my $grouping ( @common_grouping ) { - $count{"${grouping}_$status{$grouping}"}++; - } - $anydone = 1 if $status{pending} eq 'done'; - push @status, [ $bug, \%status, $html ]; - } - - my $result = ""; - if ($common_raw_sort) { - $result .= "
      \n" . join("", map( { $_->[ 2 ] } @status ) ) . "
    \n"; - } else { - my (@order, @headers); - for( my $i = 0; $i < @common_grouping; $i++ ) { - my $grouping_name = $common_grouping[ $i ]; - my @items = @{ $common_grouping_order{ $grouping_name } }; - @items = reverse( @items ) if ( $common_reverse{ $grouping_name } ); - my @neworder = (); - my @newheaders = (); - if ( @order ) { - foreach my $grouping ( @items ) { - push @neworder, map( { "${_}_$grouping" } @order ); - push @newheaders, map( { "$_ - $common_headers{$grouping_name}{$grouping}" } @headers ); - } - @order = @neworder; - @headers = @newheaders; - } else { - push @order, @items; - push @headers, map( { $common_headers{$common_grouping[$i]}{$_} } @items ); - } - } - $header .= "
      \n"; - for ( my $i = 0; $i < @order; $i++ ) { - my $order = $order[ $i ]; - next unless defined $section{$order}; - my $count = $count{"_$order"}; - my $bugs = $count == 1 ? "bug" : "bugs"; - $header .= "
    • $headers[$i] ($count $bugs)
      • \n"; - } - $header .= "
    \n"; - for ( my $i = 0; $i < @order; $i++ ) { - my $order = $order[ $i ]; - next unless defined $section{$order}; - if ($common{show_list_header}) { - my $count = $count{"_$order"}; - my $bugs = $count == 1 ? "bug" : "bugs"; - $result .= "

    $headers[$i] ($count $bugs)

    \n"; - } else { - $result .= "

    $headers[$i]

    \n"; - } - $result .= "
      \n"; - $result .= $section{$order}; - $result .= "
    \n"; - } - $footer .= "
      \n"; - foreach my $grouping ( @common_grouping ) { - my $local_result = ''; - foreach my $key ( @{$common_grouping_order{ $grouping }} ) { - my $count = $count{"${grouping}_$key"}; - next if !$count; - $local_result .= "
    • $count $common_headers{$grouping}{$key}
      • \n"; - } - if ( $local_result ) { - $footer .= "
    • $common_grouping_display{$grouping}
        \n$local_result
      • \n"; - } - } - $footer .= "
    \n"; - } - - $result = $header . $result if ( $common{show_list_header} ); - $result .= $gHTMLExpireNote if $gRemoveAge and $anydone; - $result .= "
    " . $footer if ( $common{show_list_footer} ); - return $result; -} - -sub countbugs { - return count_bugs(function=>shift, - archive => $commonarchive, - ); -} - -sub getbugs { - my $bugfunc = shift; - my $opt = shift; - - my @result = (); - - my $fastidx; - if (!defined $opt) { - # leave $fastidx undefined; - } elsif (!$common_archive) { - $fastidx = "$gSpoolDir/by-$opt.idx"; - } else { - $fastidx = "$gSpoolDir/by-$opt-arc.idx"; - } - - if (defined $fastidx && -e $fastidx) { - my %lookup; -print STDERR "optimized\n" if ($debug); - tie %lookup, MLDBM => $fastidx, O_RDONLY - or die "$0: can't open $fastidx ($!)\n"; - while ($key = shift) { - my $bugs = $lookup{$key}; - if (defined $bugs) { - push @result, keys %{$bugs}; - } - } - untie %lookup; -print STDERR "done optimized\n" if ($debug); - } else { - if ( $common_archive ) { - open I, "<$gSpoolDir/index.archive" - or &quitcgi("$gSpoolDir/index.archive: $!"); - } else { - open I, "<$gSpoolDir/index.db" - or &quitcgi("$gSpoolDir/index.db: $!"); - } - while() { - if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) { - if ($bugfunc->(pkg => $1, bug => $2, status => $4, - submitter => $5, severity => $6, tags => $7)) - { - push (@result, $2); - } - } - } - close I; - } - @result = sort {$a <=> $b} @result; - return \@result; -} - -sub emailfromrfc822 { - my $email = shift; - $email =~ s/\s*\(.*\)\s*//; - $email = $1 if ($email =~ m/<(.*)>/); - return $email; -} - -sub maintencoded { - my $input = shift; - my $encoded = ''; - - while ($input =~ m/\W/) { - $encoded.=$`.sprintf("-%02x_",unpack("C",$&)); - $input= $'; - } - - $encoded.= $input; - $encoded =~ s/-2e_/\./g; - $encoded =~ s/^([^,]+)-20_-3c_(.*)-40_(.*)-3e_/$1,$2,$3,/; - $encoded =~ s/^(.*)-40_(.*)-20_-28_([^,]+)-29_$/,$1,$2,$3/; - $encoded =~ s/-20_/_/g; - $encoded =~ s/-([^_]+)_-/-$1/g; - return $encoded; -} - - -sub getbugstatus { - my ($bug) = @_; - return get_bug_status(bug => $bug, - $use_bug_idx?(bug_index => \%bugidx):(), - usertags => \%common_bugusertags, - (defined $common_dist)?(dist => $common_dist):(), - (defined $common_version)?(version => $common_version):(), - (defined $common_arch)?(arch => $common_arch):(), - ); -} - -sub getversiondesc { - my $pkg = shift; - - if (defined $common_version) { - return "version $common_version"; - } elsif (defined $common_dist) { - my @distvers = getversions($pkg, $common_dist, $common_arch); - @distvers = sort @distvers; - local $" = ', '; - if (@distvers > 1) { - return "versions @distvers"; - } elsif (@distvers == 1) { - return "version @distvers"; - } - } - - return undef; -} - -1; diff --git a/cgi/cookies.cgi b/cgi/cookies.cgi deleted file mode 100644 index 20a9810..0000000 --- a/cgi/cookies.cgi +++ /dev/null @@ -1,45 +0,0 @@ -#!/usr/bin/perl -w - -use strict; -use POSIX qw(strftime); -require './common.pl'; - -my $oldcookies = $ENV{"HTTP_COOKIE"}; -$ENV{"HTTP_COOKIE"} = ""; -my %param = readparse(); - -my %oldcookies = map { ($1, $2) if (m/(.*)=(.*)/) } split /[;&]/, $oldcookies; - -my $clear = (defined $param{"clear"} && $param{"clear"} eq "yes"); -my @time_now = gmtime(time()); -my $time_future = strftime("%a, %d-%b-%Y %T GMT", - 59, 59, 23, 31, 11, $time_now[5]+10); -my $time_past = strftime("%a, %d-%b-%Y %T GMT", - 59, 59, 23, 31, 11, $time_now[5]-10); - -my @cookie_options = qw(repeatmerged terse reverse trim oldview); - -print "Content-Type: text/html; charset=utf-8\n"; - -for my $c (@cookie_options) { - if (defined $param{$c}) { - printf "Set-Cookie: %s=%s; expires=%s; domain=%s; path=/\n", - $c, $param{$c}, $time_future, "bugs.debian.org"; - } elsif ($clear) { - printf "Set-Cookie: %s=%s; expires=%s; domain=%s; path=/\n", - $c, "", $time_past, "bugs.debian.org"; - } -} -print "\n"; -print "

    Oldcookies $oldcookies .\n"; -print "

    Cookies set!\n"; -for my $c (@cookie_options) { - my $old = $oldcookies{$c} || "unset"; - if (defined $param{$c}) { - printf "
    Set %s=%s (was %s)\n", $c, $param{$c}, $old; - } elsif ($clear) { - printf "
    Cleared %s (was %s)\n", $c, $old; - } else { - printf "
    Didn't touch %s (was %s; use clear=yes to clear)\n", $c, $old; - } -} diff --git a/cgi/pkgindex.cgi b/cgi/pkgindex.cgi index 793cda2..a43428a 100755 --- a/cgi/pkgindex.cgi +++ b/cgi/pkgindex.cgi @@ -43,14 +43,14 @@ elsif (defined $param{prev}) { my $indexon = $param{indexon}; if ($param{indexon} !~ m/^(pkg|src|maint|submitter|tag)$/) { - quitcgi("You have to choose something to index on"); + quitcgi("You have to choose something to index on", '400 Bad Request'); } my $repeatmerged = $param{repeatmerged} eq 'yes'; my $archive = $param{archive} eq "yes"; my $sortby = $param{sortby}; if ($sortby !~ m/^(alpha|count)$/) { - quitcgi("Don't know how to sort like that"); + quitcgi("Don't know how to sort like that", '400 Bad Request'); } my $Archived = $archive ? " Archived" : ""; diff --git a/cgi/pkgreport.cgi b/cgi/pkgreport.cgi index 1ea9a17..abf739d 100755 --- a/cgi/pkgreport.cgi +++ b/cgi/pkgreport.cgi @@ -20,6 +20,7 @@ BEGIN{ binmode(STDOUT,':encoding(UTF-8)'); use POSIX qw(strftime nice); +use List::AllUtils qw(uniq); use Debbugs::Config qw(:globals :text :config); @@ -228,7 +229,8 @@ our %cats = ( "ord" => [2,3,4,1,0,5], } ], "oldview" => [ qw(status severity) ], - "normal" => [ qw(status severity classification) ], + "normal" => [ qw(status severity classification) ], + raw => [{nam => 'Raw',def => 'Raw'}], ); if (exists $param{which} and exists $param{data}) { @@ -275,7 +277,8 @@ if (defined $param{usertag}) { } } -quitcgi("You have to choose something to select by") unless grep {exists $param{$_}} keys %package_search_keys; +quitcgi("You have to choose something to select by", '400 Bad Request') + unless grep {exists $param{$_}} keys %package_search_keys; my $Archived = $param{archive} ? " Archived" : ""; @@ -494,6 +497,9 @@ print fill_in_template(template=>'cgi/pkgreport_javascript'); print qq(

    Options

    \n); +$param{orderings} = + [uniq((grep {!$hidden{$_}} keys %cats), + $param{ordering})]; print option_form(template => 'cgi/pkgreport_options', param => \%param, form_options => $form_options, diff --git a/cgi/smarturl.cgi b/cgi/smarturl.cgi deleted file mode 100644 index 4e6056a..0000000 --- a/cgi/smarturl.cgi +++ /dev/null @@ -1,95 +0,0 @@ -#!/usr/bin/perl -wT - -package debbugs; - -use strict; - -#require '/usr/lib/debbugs/errorlib'; -require './common.pl'; - -require '/etc/debbugs/config'; -require '/etc/debbugs/text'; - -use vars qw($gPackagePages $gWebDomain); - -if (defined $ENV{REQUEST_METHOD} and $ENV{REQUEST_METHOD} eq 'HEAD') { - print "Content-Type: text/html; charset=utf-8\n\n"; - exit 0; -} - -my $path = $ENV{PATH_INFO}; - -if ($path =~ m,^/(\d+)(/(\d+)(/.*)?)?$,) { - my $bug = $1; - my $msg = $3; - my $rest = $4; - - my @args = ("bug=$bug"); - push @args, "msg=$msg" if (defined $msg); - if ($rest eq "") { - 1; - } elsif ($rest eq "/mbox") { - push @args, "mbox=yes"; - } elsif ($rest =~ m,^/att/(\d+)(/[^/]+)?$,) { - push @args, "att=$1"; - push @args, "filename=$2" if (defined $2); - } else { - bad_url(); - } - - { $ENV{"PATH"}="/bin"; exec "./bugreport.cgi", "leeturls=yes", @args; } - - print "Content-Type: text/html; charset=utf-8\n\n"; - print "

    Couldn't execute bugreport.cgi!!"; - exit(0); -} else { - my $suite; - my $arch; - if ($path =~ m,^/suite/([^/]*)(/.*)$,) { - $suite = $1; $path = $2; - } elsif ($path =~ m,^/arch/([^/]*)(/.*)$,) { - $arch = $1; $path = $2; - } elsif ($path =~ m,^/suite-arch/([^/]*)/([^/]*)(/.*)$,) { - $suite = $1; $arch = $2; $path = $3; - } - - my $type; - my $what; - my $selection; - if ($path =~ m,^/(package|source|maint|submitter|severity|tag|user-tag)/([^/]+)(/(.*))?$,) { - $type = $1; $what = $2; $selection = $4 || ""; - if ($selection ne "") { - unless ($type =~ m,^(package|source|user-tag)$,) { - bad_url(); - } - } - my @what = split /,/, $what; - my @selection = split /,/, $selection; - my $typearg = $type; - $typearg = "pkg" if ($type eq "package"); - $typearg = "src" if ($type eq "source"); - - my @args = (); - push @args, $typearg . "=" . join(",", @what); - push @args, "version=" . join(",", @selection) - if ($type eq "package" and $#selection >= 0); - push @args, "utag=" . join(",", @selection) - if ($type eq "user-tag" and $#selection >= 0); - push @args, "arch=" . $arch if (defined $arch); - push @args, "suite=" . $suite if (defined $suite); - - { $ENV{"PATH"}="/bin"; exec "./pkgreport.cgi", "leeturls=yes", @args } - - print "Content-Type: text/html; charset=utf-8\n\n"; - print "

    Couldn't execute pkgreport.cgi!!"; - exit(0); - } else { - bad_url(); - } -} - -sub bad_url { - print "Content-Type: text/html; charset=utf-8\n\n"; - print "

    Bad URL :(\n"; - exit(0); -} diff --git a/debian/changelog b/debian/changelog index b91355b..41458cf 100644 --- a/debian/changelog +++ b/debian/changelog @@ -36,6 +36,30 @@ debbugs (2.6.0~exp1) UNRELEASED; urgency=low newer versions of SOAP::Lite. (Closes: #785405) * Add patch to do singular/plural in error messages from Rafael. (Closes: #790716) + * Fix (and test) setting summary/outlook in Control: messages (Closes: + #836613). + * Fix clone removing all other blocks instead of adding them (Closes: + #820044). Thanks to James Clarke. + * Use a supported version of debhelper and switch to dh $@ style rules + (Closes: #800287) + * debbugs-web now Breaks/Replaces debbugs (<< 2.4.2) (Closes: #717967) + * Split source file properly (Closes: #858671). Thanks to James McCoy. + * Prefix 'src:' to all source package names. + * cdn.libravatar.org no longer sends Content-Type. Switch to verifying + the content-type using libmagic instead (which we probably should have + been doing from the beginning anyway). (Closes: #856991) + * Reply sent messages (-forwarded and -done) are not informational messages. + (Closes: #864725) + * Pluralize singular tag and usertag in pseudoheaders (Closes: #861234). + Thanks to James Clarke + * Include link to the location of the debbugs source (Closes: #721569). + * Add envelope_from configuration variable so sites can set a valid return + path if the sendmail default is wrong. (Closes: #719205) + * Fix links to merged and blocked bugs. (Closes: #539691) + * Strip out Mail-Followup-To: (Closes: #798092) + + [ Niels Thykier ] + * quitcgi() now returns 400/500 status codes instead of 200 (Closes: #584922) [Thanks to Arnout Engelen: ] * Add Homepage (closes: #670555). @@ -391,6 +415,8 @@ debbugs (2.4.2~exp0) experimental; urgency=low #517834) * Ditch extra blank lines (closes: #494843) * Handle ' ending links in Debbugs::CGI::Bugreport (closes: #539020) + * Forcibly wrap format flowed and other messages (closes: #601242) + * Add a link to ack_thanks in process (Closes: #863274) -- Don Armstrong Sun, 26 Jul 2009 05:48:16 -0700 diff --git a/debian/compat b/debian/compat index 7ed6ff8..ec63514 100644 --- a/debian/compat +++ b/debian/compat @@ -1 +1 @@ -5 +9 diff --git a/debian/control b/debian/control index 19d9da1..6fadd40 100644 --- a/debian/control +++ b/debian/control @@ -6,16 +6,18 @@ Uploaders: Colin Watson , Don Armstrong 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 @@ -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 @@ -65,9 +67,12 @@ Description: modules used by the active Debian BTS 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 +85,7 @@ Description: web scripts for the active Debian BTS 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 diff --git a/debian/rules b/debian/rules index 7bdd341..75d02ac 100755 --- a/debian/rules +++ b/debian/rules @@ -1,73 +1,7 @@ #!/usr/bin/make -f -# Made with the aid of dh_make, by Craig Small -# Sample debian/rules that uses debhelper. GNU copyright 1997 by Joey Hess. -# Some lines taken from debmake, by Cristoph Lameter. -# Uncomment this to turn on verbose mode. -#export DH_VERBOSE=1 +%: + dh $@ --parallel -DEST_DIR := $(CURDIR)/debian/tmp -PERL ?= /usr/bin/perl - - -build: build-arch build-indep - -build-arch: -# nothing to do, as there aren't any architecture-dependent packages - -build-indep: build-stamp - -build-stamp: -# Call the test suite - $(PERL) Makefile.PL INSTALLDIRS=vendor - $(MAKE) -f Makefile.perl - $(MAKE) test - touch $@ - -clean: - dh_testdir - dh_testroot - rm -f *-stamp; - if [ -e Makefile.perl ]; then \ - $(MAKE) -f Makefile.perl clean; \ - fi; - #something to remove all trace and *.trace files? - rm -f debbugs.trace Makefile.perl.old - dh_clean - -install: install-stamp -install-stamp: build - dh_testroot - dh_clean -k - dh_installdirs - $(MAKE) install_mostfiles DESTDIR=$(DEST_DIR) - $(MAKE) -f Makefile.perl install DESTDIR=$(DEST_DIR) - touch $@ - -binary-arch: -# nothing to do, as there aren't any architecture-dependent packages - -binary-indep: build install - dh_testdir - dh_testroot - dh_clean -k - dh_installdirs - $(MAKE) install_mostfiles DESTDIR=$(DEST_DIR) - $(MAKE) -f Makefile.perl install DESTDIR=$(DEST_DIR) - dh_install --sourcedir=debian/tmp --fail-missing - dh_installdocs - dh_installchangelogs - dh_strip - dh_fixperms - #chown bugs.bugs $(var_dir)/spool/incoming - dh_installdeb - dh_perl - dh_compress -X examples/text - dh_shlibdeps - dh_gencontrol - dh_md5sums - dh_builddeb - - -binary: binary-indep binary-arch -.PHONY: build clean install binary-indep binary-arch binary +override_dh_auto_install: + dh_auto_install -- INSTALLDIRS=vendor diff --git a/examples/debian/misc/bugspam.cgi b/examples/debian/misc/bugspam.cgi index 0e94165..46bc17f 100755 --- a/examples/debian/misc/bugspam.cgi +++ b/examples/debian/misc/bugspam.cgi @@ -3,8 +3,10 @@ use strict; use CGI qw(param remote_host); -sub quitcgi($) { - my $msg = shift; +sub quitcgi($;$) { + my ($msg, $status) = @_; + $status //= '500 Internal Server Error'; + print "Status: $status\n"; print "Content-Type: text/html\n\n"; print "Error\n"; print "An error occurred. Dammit.\n"; @@ -13,8 +15,8 @@ sub quitcgi($) { exit 0; } -my $bug = param('bug') or quitcgi('No bug specfied'); -quitcgi('No valid bug number') unless $bug =~ /^\d{3,6}$/; +my $bug = param('bug') or quitcgi('No bug specfied', '400 Bad Request'); +quitcgi('No valid bug number', '400 Bad Request') unless $bug =~ /^\d{3,6}$/; my $remote_host = remote_host or quitcgi("No remote host"); my $ok = param('ok'); if (not defined $ok) { diff --git a/examples/debian/postpa/21bugclosers b/examples/debian/postpa/21bugclosers index dfcc44a..0148881 100755 --- a/examples/debian/postpa/21bugclosers +++ b/examples/debian/postpa/21bugclosers @@ -8,8 +8,6 @@ use Debbugs::Config qw(:globals); use Debbugs::Bugs qw(count_bugs); use Debbugs::Status qw(get_bug_status); -require '/org/bugs.debian.org/cgi-bin/common.pl'; - package main; my $startdate = time; diff --git a/examples/debian/postpa/22oldbugs b/examples/debian/postpa/22oldbugs index bff889d..126aa46 100755 --- a/examples/debian/postpa/22oldbugs +++ b/examples/debian/postpa/22oldbugs @@ -64,6 +64,7 @@ my $nrbugs = keys %oldpackage; open OLDBUGS, '> /org/bugs.debian.org/www/stats/oldbugs.html.new' or die "can't open oldbugs.html.new: $!"; +binmode(OLDBUGS,':encoding(UTF-8)'); print OLDBUGS <Bugs Over Two Years Old diff --git a/examples/debian/versions/build-mldbm.pl b/examples/debian/versions/build-mldbm.pl deleted file mode 100755 index 4b4d359..0000000 --- a/examples/debian/versions/build-mldbm.pl +++ /dev/null @@ -1,52 +0,0 @@ -#! /usr/bin/perl -w -use strict; -use MLDBM qw(DB_File Storable); -use Fcntl; - -$MLDBM::DumpMeth=q(portable); - -my %db; -my %db2; -tie %db, "MLDBM", "versions.idx.new", O_CREAT|O_RDWR, 0664 - or die "tie versions.idx.new: $!"; -tie %db2, "MLDBM", "versions_time.idx.new",O_CREAT|O_RDWR, 0664 - or die "tie versions_time.idx.new failed: $!"; - -my $archive = shift; -my $dist = shift; -my $arch = shift; -print "$archive/$dist/$arch\n"; - -my $time = time; -my ($p, $v); -my $extra_source_only = 0; -while (<>) { - if (/^Package: (.*)/) { $p = $1; } - elsif (/^Version: (.*)/) { $v = $1; } - elsif (/^Extra-Source-Only: yes/) { - $extra_source_only = 1; - } - elsif (/^$/) { - if ($extra_source_only) { - $extra_source_only = 0; - next; - } - update_package_version($p,$v,$time); - } -} -update_package_version($p,$v,$time) unless $extra_source_only; - -sub update_package_version { - my ($p,$v,$t) = @_; - # see MLDBM(3pm)/BUGS - my $tmp = $db{$p}; - # we allow multiple versions in an architecture now; this - # should really only happen in the case of source, however. - push @{$tmp->{$dist}{$arch}}, $v; - $db{$p} = $tmp; - $tmp = $db2{$p}; - $tmp->{$dist}{$arch}{$v} = $time if not exists - $tmp->{$dist}{$arch}{$v}; - $db2{$p} = $tmp; -} - diff --git a/examples/debian/versions/build-versions-db b/examples/debian/versions/build-versions-db new file mode 100755 index 0000000..3098587 --- /dev/null +++ b/examples/debian/versions/build-versions-db @@ -0,0 +1,241 @@ +#!/usr/bin/perl +# build-versions-db builds the versions mldmb database +# and is released under the terms of the GNU GPL version 3, or any +# later version, at your option. See the file README and COPYING for +# more information. +# Copyright 2016 by Don Armstrong . + + +use warnings; +use strict; + +use Getopt::Long; +use Pod::Usage; + +=head1 NAME + +build-versions-db -- builds source and source maintainers file + +=head1 SYNOPSIS + + build-versions-db [options] versions.idx.new versions.idx.new \ + /srv/bugs.debian.org/versions/indices/ftp + + Options: + --debug, -d debugging level (Default 0) + --help, -h display this help + --man, -m display manual + +=head1 OPTIONS + +=over + +=item B<--update> + +Update an existing database; the default. B<--no-update> will regenerate an +existing database from scratch. + +=item B<--debug, -d> + +Debug verbosity. (Default 0) + +=item B<--help, -h> + +Display brief usage information. + +=item B<--man, -m> + +Display this manual. + +=back + +=head1 EXAMPLES + + build-versions-db versions.idx.new versions.idx.new \ + /srv/bugs.debian.org/versions/indices/ftp \ + stable + +=cut + + +use vars qw($DEBUG); +use Debbugs::Versions::Dpkg; +use Debbugs::Config qw(:config); +use File::Copy; +use MLDBM qw(DB_File Storable); +use Fcntl; + +my %options = (debug => 0, + help => 0, + man => 0, + update => 1, + ); + +GetOptions(\%options, + 'update!', + 'debug|d+','help|h|?','man|m'); + +pod2usage() if $options{help}; +pod2usage({verbose=>2}) if $options{man}; + +$DEBUG = $options{debug}; + +my @USAGE_ERRORS; + +if (not @ARGV >= 4) { + push @USAGE_ERRORS, + "You must provide at least four arguments, two databases, ". + "a top level directory and at least one suite"; +} + + +pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS; + + +my $versions = shift @ARGV; +my $versions_time = shift @ARGV; +my $versions_new = $versions."_".$$."_".time; +my $versions_time_new = $versions_time."_".$$."_".time; +my $toplevel = shift @ARGV; +my @suites = @ARGV; + +$MLDBM::DumpMeth=q(portable); + +my $time = time; + +my %db; +my %db2; +if ($options{update}) { + copy($versions_time,$versions_time_new); +} +tie %db, "MLDBM", $versions_new, O_CREAT|O_RDWR, 0664 + or die "tie $versions: $!"; +tie %db2, "MLDBM", $versions_time_new,O_CREAT|O_RDWR, 0664 + or die "tie $versions_time failed: $!"; + +update_versions_suites(\%db,\%db2,\@suites); +versions_time_cleanup(\%db2) if $options{update}; + +move($versions_new,$versions); +move($versions_time_new,$versions_time); + +sub open_compressed_file { + my ($file) = @_; + my $fh; + my $mode = '<:encoding(UTF-8)'; + my @opts; + if ($file =~ /\.gz$/) { + $mode = '-|:encoding(UTF-8)'; + push @opts,'gzip','-dc'; + } + if ($file =~ /\.xz$/) { + $mode = '-|:encoding(UTF-8)'; + push @opts,'xz','-dc'; + } + if ($file =~ /\.bz2$/) { + $mode = '-|:encoding(UTF-8)'; + push @opts,'bzip2','-dc'; + } + open($fh,$mode,@opts,$file); + return $fh; +} + +# Read Package, Version, and Source fields from a Packages.gz file. +sub read_packages { + my ($db,$db2,$packages, $component,$arch,$dist) = @_; + my $PACKAGES = open_compressed_file($packages) or + die "Unable to open $packages for reading: $!"; + local $_; + local $/ = ''; # paragraph mode + + print STDERR "reading packages $packages\n" if $DEBUG; + for (<$PACKAGES>) { + /^Package: (.+)/im or next; + my $pkg = $1; + /^Version: (.+)/im or next; + my $ver = $1; + my $extra_source_only = 0; + if (/^Extra-Source-Only: yes/im) { + $extra_source_only = 1; + } + update_package_version($db,$db2,$dist,$arch,$pkg,$ver,$time) unless + $extra_source_only; + } + close($PACKAGES) or + die "Error while closing ${packages}: $!"; +} + + +sub update_package_version { + my ($db,$db2,$d,$a,$p,$v,$t) = @_; + # see MLDBM(3pm)/BUGS + my $tmp = $db->{$p}; + # we allow multiple versions in an architecture now; this + # should really only happen in the case of source, however. + push @{$tmp->{$d}{$a}}, $v; + $db->{$p} = $tmp; + $tmp = $db2->{$p}; + $tmp->{$d}{$a}{$v} = $time if not exists + $tmp->{$d}{$a}{$v}; + $db2->{$p} = $tmp; +} + +sub update_versions_suites { + my ($db,$db2,$suites) = @_; +# Iterate through all Packages and Sources files. +for my $suite (@{$suites}) { + my $suitedir = "$toplevel/$suite"; + + for my $component ('main', 'main/debian-installer', + 'contrib', 'non-free') { + my $componentdir = "$suitedir/$component"; + next unless -d $componentdir; + my $COMPONENT; + opendir $COMPONENT, $componentdir or die "opendir $componentdir: $!"; + + # debian-installer is really a section rather than a component + # (ugh). + (my $viscomponent = $component) =~ s[/.*][]; + + my $sources = (grep { -f $_ } glob "$suitedir/$component/source/Sources.*")[0]; + next unless defined $sources; + read_packages($db,$db2,$sources, $viscomponent,'source',$suite); + + for my $arch (readdir $COMPONENT) { + next unless $arch =~ s/^binary-//; + my $archdir = "$componentdir/binary-$arch"; + + my $packages = (grep { -f $_ } glob("$archdir/Packages.*"))[0]; + next unless defined $packages; + read_packages($db,$db2,$packages, $viscomponent,$arch,$suite); + } + + closedir $COMPONENT or + die "Unable to closedir $componentdir: $!"; + } +} +} + +sub versions_time_cleanup { + my ($db) = @_; + my $time = time; + for my $package (keys %{$db}) { + my $temp = $db->{$package}; + for my $dist (keys %{$temp}) { + for my $arch (keys %{$temp->{$dist}}) { + my @versions = (sort {$temp->{$dist}{$arch}{$a} <=> + $temp->{$dist}{$arch}{$b} + } + keys %{$temp->{$dist}{$arch}}); + next unless @versions > 1; + for my $i (0 .. ($#versions-1)) { + last if $temp->{$dist}{$arch}{$versions[$i+1]} > + ($time - $config{remove_age}*60*60*24); + last if keys %{$temp->{$dist}{$arch}} <= 1; + delete $temp->{$dist}{$arch}{$versions[$i]}; + } + } + } + $db->{$package} = $temp; + } +} diff --git a/examples/debian/versions/update-mldbm b/examples/debian/versions/update-mldbm index 3bb03bc..9a89302 100755 --- a/examples/debian/versions/update-mldbm +++ b/examples/debian/versions/update-mldbm @@ -4,69 +4,10 @@ cd /org/bugs.debian.org/versions/indices ARCHIVES='ftp' # security -- should be included too, but too difficult to deal with -# Nuke old versions of versions.idx.new in case there's one hanging about -rm -f versions.idx.new -# This index is much larger and keeps track of historic versions of -# packages, and is used for expiring bugs -rm -f versions_time.idx.new -if [ -e versions_time.idx ]; then - cp versions_time.idx versions_time.idx.new; -fi; - -set -e -for archive in $ARCHIVES; do - case $archive in - ftp) - SUITES='oldstable stable proposed-updates testing testing-proposed-updates unstable experimental' - di_main='main main/debian-installer' - ;; - nonus) - SUITES='oldstable' - di_main='main' - ;; - security) - SUITES='oldstable stable testing' - di_main='main' - ;; - esac - for suite in $SUITES; do - if [ "$suite" != "oldstable" ] || [ -d /org/bugs.debian.org/etc/indices/$archive/$suite ]; then - case $suite in - oldstable|stable|proposed-updates) - 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' - ;; - unstable|experimental) - ARCHES='alpha amd64 arm hppa hurd-i386 i386 ia64 m68k mips mipsel powerpc s390 sparc' - ;; - esac - case $suite in - oldstable|experimental) - COMPONENTS='main contrib non-free' - ;; - stable|proposed-updates|testing|testing-proposed-updates|unstable) - COMPONENTS="$di_main contrib non-free" - ;; - esac - for component in $COMPONENTS; do - for arch in $ARCHES; do - zcat "/org/bugs.debian.org/etc/indices/$archive/$suite/$component/binary-$arch/Packages.gz" | ../bin/build-mldbm.pl "$archive" "$suite" "$arch" - done - if [ "$component" != main/debian-installer ]; then - zcat "/org/bugs.debian.org/etc/indices/$archive/$suite/$component/source/Sources.gz" | ../bin/build-mldbm.pl "$archive" "$suite" source - fi - done - fi - done -done - -# This removes old versions -../bin/versions_time_cleanup - -chmod 664 versions.idx.new -mv versions.idx.new versions.idx - -chmod 664 versions_time.idx.new -mv versions_time.idx.new versions_time.idx \ No newline at end of file +../bin/build-versions-db versions.idx versions_time.idx \ + /srv/bugs.debian.org/versions/indices/ftp \ + oldstable stable proposed-updates \ + testing \ + testing-proposed-updates \ + unstable \ + experimental; diff --git a/html/bugs.css b/html/bugs.css index 9019b9d..1fb0198 100644 --- a/html/bugs.css +++ b/html/bugs.css @@ -102,6 +102,11 @@ pre.message { padding-top: 8px; margin-top: 0; border-top: 0; + white-space: pre-wrap; +} + +pre.wrapping { + width: 80ch; } .sparse li { @@ -181,6 +186,18 @@ pre.mime { color: #686868; } +.msgreceived p { + width: 120ch; + margin-top: 0px; + margin-bottom: 0px; +} + +p.msgreceived { + width: 120ch; + margin-top: 0px; + margin-bottom: 0px; +} + .buginfo p { font-family: sans-serif; diff --git a/html/index.html.in b/html/index.html.in index d1b5682..5e8b466 100644 --- a/html/index.html.in +++ b/html/index.html.in @@ -36,13 +36,13 @@ $gHTMLCopies

    Find a bug by number:
    -

    + as mbox
    -
    +

    Find bugs by: package source package @@ -57,24 +57,24 @@ What to search for:

    The following bug report indices are available:

    diff --git a/html/server-request.html.in b/html/server-request.html.in index 7941c53..22021a8 100644 --- a/html/server-request.html.in +++ b/html/server-request.html.in @@ -179,7 +179,7 @@ sending help to control\@$gEmailDomain.

    In case you are reading this as a plain text file or via email: an HTML version is available via the $gBug system main contents page -http://$gWebDomain/. +$gWebDomain/.

    diff --git a/scripts/config.in.default b/scripts/config.in.default index d8c8ea1..f8c03b2 100644 --- a/scripts/config.in.default +++ b/scripts/config.in.default @@ -3,7 +3,7 @@ $gEmailDomain = "bugs.top.domain"; #bugs.debian.org $gListDomain = "lists.top.domain"; #lists.debian.org $gWebHostBugDir = ""; -$gWebDomain = "www.top.domain"; #www.debian.org/Bugs +$gWebDomain = "https://www.top.domain"; #www.debian.org/Bugs $gCGIDomain = "cgi.top.domain"; #cgi.debian.org #Identification diff --git a/scripts/gen-indices b/scripts/gen-indices index 7a8670d..1f0e7df 100755 --- a/scripts/gen-indices +++ b/scripts/gen-indices @@ -18,7 +18,7 @@ use Getopt::Long; use Pod::Usage; use File::stat; -use List::Util qw(min); +use List::AllUtils qw(min); use Debbugs::Common qw(make_list); diff --git a/scripts/mailsummary b/scripts/mailsummary index 1ed2e0b..9e04332 100755 --- a/scripts/mailsummary +++ b/scripts/mailsummary @@ -74,7 +74,7 @@ Every Friday, the listing by age of the report is posted. Please see the documentation for more information about how to use the $gBug tracking system. It is available on the WWW at -$gWebDomain/txt +$gWebDomain/txt END close(D); diff --git a/scripts/process b/scripts/process index 4c38000..38e4f90 100755 --- a/scripts/process +++ b/scripts/process @@ -180,8 +180,8 @@ for my $hdr (@headerlines) { $_ = $hdr; s/\n\s/ /g; finish() if m/^x-loop: (\S+)$/i && $1 eq "$gMaintainerEmail"; - my $ins = !m/^subject:/i && !m/^reply-to:/i && !m/^return-path:/i - && !m/^From / && !m/^X-Debbugs-/i; + my $ins = !m/^(?:(?:subject|reply-to|return-path|mail-followup-to): + |From\s|X-Debbugs-)/xi; $fwd .= encode_utf8($hdr)."\n" if $ins; # print {$debugfh} ">$_<\n"; if (s/^(\S+):\s*//) { @@ -225,9 +225,14 @@ for my $phline (@bodylines) # Fixes #488554 $phline =~ s/\xef\xbb\xbf//g; $phline =~ s/\N{U+FEFF}//g; - last if $phline !~ m/^([\w-]+):\s*(\S.*)/; + last if $phline !~ m/^([\w-]+): # psuedoheader + (?:\s|\N{U+00A0})* # zero or more spaces, including + # non-breaking space + (\S.*)/x; # pseudoheader value my ($fn, $fv) = ($1, $2); $fv =~ s/\s*$//; + # pluralize tag/usertag + $fn = $fn.'s' if $fn =~ /^(?:tag|usertag)$/; print {$debugfh} ">$fn|$fv|\n"; $fn = lc $fn; if ($fn =~ /^control$/) { @@ -501,6 +506,8 @@ if ($codeletter eq 'D' || $codeletter eq 'F') "X-$gProject-PR-Keywords" => $data->{keywords}, # Only have a X-$gProject-PR-Source when we know the source package (defined($source_package) and length($source_package))?("X-$gProject-PR-Source" => $source_package):(), + "Reply-To" => "$ref\@$gEmailDomain", + "Content-Type" => 'text/plain; charset="utf-8"', ],message_body_template('mail/process_mark_as_forwarded', {date => $header{date}, messageid => $header{'message-id'}, @@ -524,6 +531,8 @@ if ($codeletter eq 'D' || $codeletter eq 'F') "X-$gProject-PR-Keywords" => $data->{keywords}, # Only have a X-$gProject-PR-Source when we know the source package (defined($source_package) and length($source_package))?("X-$gProject-PR-Source" => $source_package):(), + "Reply-To" => "$ref\@$gEmailDomain", + "Content-Type" => 'text/plain; charset="utf-8"', ],message_body_template('mail/process_mark_as_done', {date => $header{date}, messageid => $header{'message-id'}, @@ -592,7 +601,8 @@ if ($ref<0) { # new bug report if (defined $pheader{source}) { # source packages are identified by the src: prefix - $data->{package} = 'src:'.$pheader{source}; + $data->{package} = $pheader{source}; + $data->{package} =~ s/(^|,\s*)/${1}src:/g; } elsif (defined $pheader{package}) { $data->{package} = $pheader{package}; if ($data->{package} =~ /^src:(.+)/) { @@ -1015,7 +1025,7 @@ if (@control_bits) { request_subject => $header{subject}, request_nn => $nn, request_replyto => $replyto, - message => $msg, + message => [$msg], affected_bugs => \%bug_affected, affected_packages => \%affected_packages, recipients => \%recipients, @@ -1261,7 +1271,7 @@ sub fill_template{ }; my $hole_var = {'&bugurl' => sub{"$_[0]: ". - 'http://'.$config{cgi_domain}.'/'. + $config{cgi_domain}.'/'. Debbugs::CGI::bug_links(bug=>$_[0], links_only => 1, ); diff --git a/scripts/receive b/scripts/receive index eb101a4..86367bf 100755 --- a/scripts/receive +++ b/scripts/receive @@ -103,10 +103,10 @@ $gBadEmailPrefix $gBadEmailPrefix (all \@$gEmailDomain.) $gBadEmailPrefix $gBadEmailPrefix For instructions via the WWW see: -$gBadEmailPrefix http://$gWebDomain/ -$gBadEmailPrefix http://$gWebDomain/Reporting$gHTMLSuffix -$gBadEmailPrefix http://$gWebDomain/Developer$gHTMLSuffix -$gBadEmailPrefix http://$gWebDomain/Access$gHTMLSuffix +$gBadEmailPrefix $gWebDomain/ +$gBadEmailPrefix $gWebDomain/Reporting$gHTMLSuffix +$gBadEmailPrefix $gWebDomain/Developer$gHTMLSuffix +$gBadEmailPrefix $gWebDomain/Access$gHTMLSuffix $gTextInstructions $gBadEmailPrefix For details of how to access $gBug report logs by email: $gBadEmailPrefix send \`request\@$gEmailDomain' the word \`help' diff --git a/scripts/service b/scripts/service index 10fbbc0..0196e26 100755 --- a/scripts/service +++ b/scripts/service @@ -40,7 +40,7 @@ use Debbugs::Text qw(:templates); use Scalar::Util qw(looks_like_number); -use List::Util qw(first); +use List::AllUtils qw(first); use Mail::RFC822::Address; use Encode qw(decode encode); @@ -285,7 +285,7 @@ for ($procline=0; $procline<=$#bodylines; $procline++) { } elsif (m/^subscribe/i) { print {$transcript} < sub{"$_[0]: ". - 'http://'.$config{cgi_domain}.'/'. + $config{cgi_domain}.'/'. Debbugs::CGI::bug_links(bug=>$_[0], links_only => 1, ); @@ -901,7 +901,7 @@ END sub sendlynxdocraw { my ($relpath,$description) = @_; $doc=''; - open(L,"lynx -nolist -dump http://$gCGIDomain/\Q$relpath\E 2>&1 |") || die "fork for lynx: $!"; + open(L,"lynx -nolist -dump $gCGIDomain/\Q$relpath\E 2>&1 |") || die "fork for lynx: $!"; while() { $doc.=$_; } $!=0; close(L); if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) { diff --git a/scripts/text b/scripts/text index a1a6a00..a6ae98e 100644 --- a/scripts/text +++ b/scripts/text @@ -181,7 +181,7 @@ $gHTMLTail = "

    - Debian $gBug tracking system
    + Debian $gBug tracking system
    Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson. diff --git a/t/02_version_dpkg.t b/t/02_version_dpkg.t index f435bef..e613455 100644 --- a/t/02_version_dpkg.t +++ b/t/02_version_dpkg.t @@ -40,16 +40,6 @@ my @versions = ({a => '1.0-1', result => -1, relation => 'lt', }, - {a => '1foo-', - b => '1foo', - result => 0, - relation => 'eq', - }, - {a => '1foo-', - b => '1foo+', - result => -1, - relation => 'lt', - }, ); plan tests => @versions * 2 + 1; diff --git a/t/06_mail_handling.t b/t/06_mail_handling.t index 9489af0..0e42ed0 100644 --- a/t/06_mail_handling.t +++ b/t/06_mail_handling.t @@ -26,25 +26,14 @@ use Encode qw(decode encode); # 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 %config = create_debbugs_configuration(); + 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. diff --git a/t/07_bugreport.t b/t/07_bugreport.t index 5dfca05..dfc1650 100644 --- a/t/07_bugreport.t +++ b/t/07_bugreport.t @@ -24,22 +24,8 @@ use HTTP::Status qw(RC_NOT_MODIFIED); use lib qw(t/lib); use DebbugsTest qw(:all); -my %config; -eval { - %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0); -}; -if ($@) { - BAIL_OUT($@); -} +my %config = create_debbugs_configuration(); -# Output some debugging information if there's an error -END{ - if ($ENV{DEBUG}) { - foreach my $key (keys %config) { - diag("$key: $config{$key}\n"); - } - } -} # create a bug send_message(to=>'submit@bugs.something', diff --git a/t/07_control_limit.t b/t/07_control_limit.t index 02cfc37..ae3e98a 100644 --- a/t/07_control_limit.t +++ b/t/07_control_limit.t @@ -24,25 +24,14 @@ 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 %config = create_debbugs_configuration(); + 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. diff --git a/t/08_pkgreport.t b/t/08_pkgreport.t index df4861d..eabee52 100644 --- a/t/08_pkgreport.t +++ b/t/08_pkgreport.t @@ -23,22 +23,8 @@ use Test::WWW::Mechanize; use lib qw(t/lib); use DebbugsTest qw(:all); -my %config; -eval { - %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0); -}; -if ($@) { - BAIL_OUT($@); -} - -# Output some debugging information if there's an error -END{ - if ($ENV{DEBUG}) { - foreach my $key (keys %config) { - diag("$key: $config{$key}\n"); - } - } -} +my %config = create_debbugs_configuration(); + # create a bug send_message(to=>'submit@bugs.something', @@ -60,8 +46,7 @@ EOF my $pkgreport_cgi_handler = sub { # I do not understand why this is necessary. $ENV{DEBBUGS_CONFIG_FILE} = "$config{config_dir}/debbugs_config"; - # We cd here because pkgreport uses require ./common.pl - my $content = qx(cd cgi; perl -I.. -T pkgreport.cgi); + my $content = qx(perl -I. -T cgi/pkgreport.cgi); # Strip off the Content-Type: stuff $content =~ s/^\s*Content-Type:[^\n]+\n*//si; print $content; diff --git a/t/09_soap.t b/t/09_soap.t index 4967a9c..266c4c5 100644 --- a/t/09_soap.t +++ b/t/09_soap.t @@ -17,22 +17,8 @@ use lib qw(t/lib); use DebbugsTest qw(:configuration); use Cwd; -my %config; -eval { - %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0); -}; -if ($@) { - BAIL_OUT($@); -} +my %config = create_debbugs_configuration(); -# Output some debugging information if we're debugging -END{ - if ($ENV{DEBUG}) { - foreach my $key (keys %config) { - diag("$key: $config{$key}\n"); - } - } -} # create a bug send_message(to=>'submit@bugs.something', diff --git a/t/10_expire.t b/t/10_expire.t index 502feea..311b9b3 100644 --- a/t/10_expire.t +++ b/t/10_expire.t @@ -25,25 +25,14 @@ 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 %config = create_debbugs_configuration(); + 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. diff --git a/t/11_blocks.t b/t/11_blocks.t index 11c765a..72f7c35 100644 --- a/t/11_blocks.t +++ b/t/11_blocks.t @@ -25,25 +25,14 @@ use Test::WWW::Mechanize; # 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 %config = create_debbugs_configuration(); + 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. diff --git a/t/12_merge.t b/t/12_merge.t index f07b4e6..c654359 100644 --- a/t/12_merge.t +++ b/t/12_merge.t @@ -24,25 +24,14 @@ 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 %config = create_debbugs_configuration(); + 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. diff --git a/t/13_utf8_mail.t b/t/13_utf8_mail.t index 7ef4aaf..b98154e 100644 --- a/t/13_utf8_mail.t +++ b/t/13_utf8_mail.t @@ -28,25 +28,14 @@ use Encode qw(decode encode decode_utf8 encode_utf8); # 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 %config = create_debbugs_configuration(); + 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. diff --git a/t/14_control_at_submit.t b/t/14_control_at_submit.t index 6688f53..950d1a9 100644 --- a/t/14_control_at_submit.t +++ b/t/14_control_at_submit.t @@ -26,25 +26,14 @@ use Encode qw(decode encode); # 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 %config = create_debbugs_configuration(); + 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. diff --git a/t/15_rebuild_indexdb.t b/t/15_rebuild_indexdb.t index a0ca910..6f6aa21 100644 --- a/t/15_rebuild_indexdb.t +++ b/t/15_rebuild_indexdb.t @@ -27,25 +27,14 @@ use Encode qw(decode encode decode_utf8 encode_utf8); # 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 %config = create_debbugs_configuration(); + 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. diff --git a/t/18_libravatar_cgi.t b/t/18_libravatar_cgi.t index 4d20e47..ec938cc 100644 --- a/t/18_libravatar_cgi.t +++ b/t/18_libravatar_cgi.t @@ -16,19 +16,12 @@ my $port = 11344; $SIG{CHLD} = sub {}; our %config; eval { - %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0); + %config = create_debbugs_configuration(); }; if ($@) { BAIL_OUT($@); } $ENV{DEBBUGS_CONFIG_FILE} = "$config{config_dir}/debbugs_config"; -END{ - if ($ENV{DEBUG}) { - diag("spool_dir: $config{spool_dir}\n"); - diag("config_dir: $config{config_dir}\n"); - diag("sendmail_dir: $config{sendmail_dir}\n"); - } -} my $libravatar_cgi_handler = sub { my $fh; diff --git a/t/19_summary_current_message.t b/t/19_summary_current_message.t new file mode 100644 index 0000000..0dfc1e7 --- /dev/null +++ b/t/19_summary_current_message.t @@ -0,0 +1,91 @@ +# -*- mode: cperl;-*- + +use Test::More; + +use warnings; +use strict; + +# The test functions are placed here to make things easier +use lib qw(t/lib); +use DebbugsTest qw(:all); +use Data::Dumper; + +my %config = + create_debbugs_configuration(); + +my $sendmail_dir = $config{sendmail_dir}; +my $spool_dir = $config{spool_dir}; + +# 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 => < 'control@bugs.something', + headers => [To => 'control@bugs.something', + From => 'foo@bugs.something', + Subject => 'Munging a bug', + ], + body => <1); +is($status->{summary},"This is the summary of the silly bug",'bug 1 has right summary'); + +send_message(to => '1@bugs.something', + headers => [To => '1@bugs.something', + From => 'foo@bugs.something', + Subject => 'Munging a bug', + ], + body => <1); +is($status->{summary},"This is a new summary.",'Control: summary setting works'); + + +done_testing(); diff --git a/t/20_multipart_mime_pseudoheaders.t b/t/20_multipart_mime_pseudoheaders.t new file mode 100644 index 0000000..f8aae48 --- /dev/null +++ b/t/20_multipart_mime_pseudoheaders.t @@ -0,0 +1,81 @@ +# -*- mode: cperl;-*- + +use Test::More; + +use warnings; +use strict; +use utf8; + +# The test functions are placed here to make things easier +use lib qw(t/lib); +use DebbugsTest qw(:all); +use Data::Dumper; + +my %config = + create_debbugs_configuration(); + +my $sendmail_dir = $config{sendmail_dir}; +my $spool_dir = $config{spool_dir}; + +# 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 => < [<'1-done@bugs.something', + headers => [To => '1-done@bugs.something', + From => 'foo@bugs.something', + Subject => 'Closing a bug with pseudoheaders', + ], + body => < [<1); +is($status->{done},'foo@bugs.something','bug 1 was closed properly'); +is_deeply($status->{fixed_versions},["1"],'bug 1 was fixed in the proper version'); + +done_testing(); diff --git a/t/lib/DebbugsTest.pm b/t/lib/DebbugsTest.pm index 603b6ec..6e33399 100644 --- a/t/lib/DebbugsTest.pm +++ b/t/lib/DebbugsTest.pm @@ -57,7 +57,8 @@ BEGIN{ sub create_debbugs_configuration { my %param = validate_with(params => \@_, spec => {debug => {type => BOOLEAN, - default => 0, + default => exists $ENV{DEBUG}? + $ENV{DEBUG}:0, }, cleanup => {type => BOOLEAN, optional => 1, @@ -73,6 +74,7 @@ sub create_debbugs_configuration { $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config"; $ENV{PERL5LIB} = getcwd(); $ENV{SENDMAIL_TESTDIR} = $sendmail_dir; + eval { my $sendmail_tester = getcwd().'/t/sendmail_tester'; unless (-x $sendmail_tester) { die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.); @@ -119,7 +121,17 @@ END } system('mkdir','-p',"$spool_dir/incoming"); system('mkdir','-p',"$spool_dir/lock"); + eval ' +END{ + if ($ENV{DEBUG}) { + diag("spool_dir: $spool_dir\n"); + diag("config_dir: $config_dir\n",); + diag("sendmail_dir: $sendmail_dir\n"); + } +}'; + }; + BAIL_OUT ($@) if ($@); return (spool_dir => $spool_dir, sendmail_dir => $sendmail_dir, config_dir => $config_dir, @@ -193,6 +205,8 @@ sub send_message{ } } +$SIG{CHLD} = sub {}; + { package DebbugsTest::HTTPServer; use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment); diff --git a/templates/en_US/cgi/bugreport.tmpl b/templates/en_US/cgi/bugreport.tmpl index b4ec416..2f0ec04 100644 --- a/templates/en_US/cgi/bugreport.tmpl +++ b/templates/en_US/cgi/bugreport.tmpl @@ -43,7 +43,7 @@ function toggle_infmessages() } {$log}

    -

    Send a report that this bug log contains spam.

    +

    Send a report that this bug log contains spam.

    {include(q(html/html_tail))} diff --git a/templates/en_US/cgi/no_such_bug.tmpl b/templates/en_US/cgi/no_such_bug.tmpl index 5434b53..bdbd67d 100644 --- a/templates/en_US/cgi/no_such_bug.tmpl +++ b/templates/en_US/cgi/no_such_bug.tmpl @@ -4,6 +4,6 @@

    {$config{project}} {$config{bug}} report logs - #{$bug_num}

    There is no record of {$config{bug}} #{$bug_num}. -Try the search page instead.

    +Try the search page instead.

    {#include('html/html_tail')} diff --git a/templates/en_US/cgi/pkgreport_options.tmpl b/templates/en_US/cgi/pkgreport_options.tmpl index d025d97..da362dd 100644 --- a/templates/en_US/cgi/pkgreport_options.tmpl +++ b/templates/en_US/cgi/pkgreport_options.tmpl @@ -46,13 +46,9 @@ include('cgi/pkgreport_options_include_exclude'); -

    Categorize using

    - - -

    Order by

    +

    Categorize/Order using